diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 6b28fc6fa1..47c470a1fe 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -83,3 +83,5 @@ jobs: stack --no-terminal exec transcripts git diff x=`git status --porcelain -uno` bash -c 'if [[ -n $x ]]; then echo "$x" && false; fi' + - name: prettyprint-round-trip + run: stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 6df1e3285b..febd40be52 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -57,3 +57,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha * Simon HΓΈjberg (@hojberg) * David Smith (@shmish111) * Chris Penner (@ChrisPenner) +* Rebecca Mark (@rlmark) diff --git a/development.markdown b/development.markdown index 1d9babb2cf..5ef3ca8809 100644 --- a/development.markdown +++ b/development.markdown @@ -21,6 +21,7 @@ On startup, Unison prints a url for the codebase UI. If you did step 3 above, th * `stack exec tests` runs the tests * `stack exec transcripts` runs all the integration tests, found in `unison-src/transcripts`. You can add more tests to this directory. * `stack exec tests -- prefix-of-test` and `stack exec transcripts -- prefix-of-test` only run tests with a matching prefix. +* `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests ### What if you want a profiled build? diff --git a/docs/release-steps.md b/docs/release-steps.md new file mode 100644 index 0000000000..cfb205661f --- /dev/null +++ b/docs/release-steps.md @@ -0,0 +1,107 @@ + +__0__ + +Communicate with core team - we are cutting a release now, are there any showstopping bugs that need fixing first? + +__1__ + +Create and push the tag to github. This will trigger the build. To determine the last release, check [the releases page](https://github.com/unisonweb/unison/releases). + +``` +git fetch +git checkout series/M2 +git merge origin/trunk +git tag -a release/$RELEASE_NAME -m "release" +git push origin release/$RELEASE_NAME +``` + +__2__ + +Wait for the release to show up on [the releases page](https://github.com/unisonweb/unison/releases). This can take an hour or two! + +__3__ + +Create a release notes draft issue, following [this template](https://github.com/unisonweb/unison/issues/2342) and updating the output of PRs merged and contributors to the release. + +__4__ + +Update trunk of `base` to include any new builtins added since last release. Suggestion for how to do this: look through the release notes draft to find the PRs merged since last release. @runarorma does this usually. + +``` +git log --oneline release/M2h...release/M2i | grep 'Merge pull request #' +``` + +Then just use `alias.term ##Nat.newBuiltin Nat.someName` and/or `alias.type ##SomeType SomeType`. I think this is probably better than doing `builtins.merge` at this point. + +__5__ + +Cut a release of base. @runarorama does this usually. + +``` +.> pull https://unisonweb/base basedev.release +.> cd basedev.release +.basedev.release> delete.namespace releases._latest +.basedev.release> squash trunk releases._ +.basedev.release> fork releases._ releases._latest +.basedev.release> push git@github.com/unisonweb/base +``` + +__6__ + +Update homebrew. + +``` +git clone git@github.com/unisonweb/homebrew-unison +``` + +Update this file: https://github.com/unisonweb/homebrew-unison/blob/master/unison-language.rb and change the version number and the path to the release. Leave the SHA alone, and then run `brew upgrade`. + +Do `brew upgrade unison-language`. It will tell you the SHA hash doesn't match. Update the file to use the hash it says. +Do the same for linux and mac - you can temporarily swap the mac / linux stanzas just to get the value for the other platform. + +__7__ + +Merge and promote to production any PRs pending [on the docs site](https://github.com/unisonweb/unisonweb-org/pulls) which are associated with the new release. Confirm with @rlmark. + +__8__ + +Bug @pchiusano to update [the Slack post](https://unisonlanguage.slack.com/files/TLL09QC85/FMT7TDDDY?origin_team=TLL09QC85) which provides install instructions for people coming from [the quickstart guide](https://www.unisonweb.org/docs/quickstart/). + +__9__ + +Announce on #contrib Slack channel. Template below. + +--- + +Release announcement template (be sure to update the release urls) - + +We've just released a new version of Unison, $RELEASE_NAME, release notes here (link to the issue). Install/upgrade instructions in the thread. + +Mac upgrade is just `brew upgrade unison-language`. + +A fresh install via: + +``` +brew tap unisonweb/unison +brew install unison-language +``` + +If you have previously done brew install unison-language --head to install a dev build, uninstall that first via brew uninstall unison-language. + +_Linux manual install:_ + +``` +mkdir unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/download/release%2FM2h/ucm-linux.tar.gz --output unisonlanguage/ucm.tar.gz +tar -xzf unisonlanguage/ucm.tar.gz -C unisonlanguage +./unisonlanguage/ucm +``` + +_Mac manual install:_ + +``` +mkdir unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/download/release%2FM2h/ucm-macos.tar.gz --output unisonlanguage/ucm.tar.gz +tar -xzf unisonlanguage/ucm.tar.gz -C unisonlanguage +./unisonlanguage/ucm +``` diff --git a/parser-typechecker/.DS_Store b/parser-typechecker/.DS_Store new file mode 100644 index 0000000000..949ebd51bf Binary files /dev/null and b/parser-typechecker/.DS_Store differ diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index ab978bbfc8..1d371936ce 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -44,6 +44,7 @@ library: - configurator - cryptonite - data-default + - deepseq - directory - either - fuzzyfind @@ -75,6 +76,7 @@ library: - optparse-applicative >= 0.16.1.0 - openapi3 - pem + - prelude-extras - process - primitive - random >= 1.2.0 @@ -108,6 +110,7 @@ library: - x509 - x509-store - x509-system + - zlib - unison-codebase - unison-codebase-sqlite - unison-codebase-sync @@ -143,6 +146,7 @@ executables: - unison-parser-typechecker - unison-codebase-sync - uri-encode + - unliftio when: - condition: '!os(windows)' dependencies: unix @@ -203,6 +207,8 @@ executables: - text - unison-core1 - unison-parser-typechecker + build-tools: + - unison-parser-typechecker:unison benchmarks: runtime: diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index efdd0ef2f3..5e1a9b47ed 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -33,7 +33,7 @@ import Unison.Codebase.CodeLookup ( CodeLookup(..) ) import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as TD import qualified Unison.DataDeclaration as DD -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann (..)) import qualified Unison.Reference as R import qualified Unison.Referent as Referent import Unison.Symbol ( Symbol ) @@ -46,6 +46,7 @@ import Unison.Names3 (Names(Names), Names0) import qualified Unison.Names3 as Names3 import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.Util.Relation as Rel +import qualified Unison.Hashing.V2.Convert as H type DataDeclaration v = DD.DataDeclaration v Ann type EffectDeclaration v = DD.EffectDeclaration v Ann @@ -106,7 +107,7 @@ builtinDependencies = -- a relation whose domain is types and whose range is builtin terms with that type builtinTermsByType :: Rel.Relation R.Reference Referent.Referent builtinTermsByType = - Rel.fromList [ (Type.toReference ty, Referent.Ref r) + Rel.fromList [ (H.typeToReference ty, Referent.Ref r) | (r, ty) <- Map.toList (termRefTypes @Symbol) ] -- a relation whose domain is types and whose range is builtin terms that mention that type @@ -114,7 +115,7 @@ builtinTermsByType = builtinTermsByTypeMention :: Rel.Relation R.Reference Referent.Referent builtinTermsByTypeMention = Rel.fromList [ (m, Referent.Ref r) | (r, ty) <- Map.toList (termRefTypes @Symbol) - , m <- toList $ Type.toReferenceMentions ty ] + , m <- toList $ H.typeToReferenceMentions ty ] -- The dependents of a builtin type is the set of builtin terms which -- mention that type. @@ -179,6 +180,8 @@ builtinTypesSrc = , B' "Tls.Cipher" CT.Data, Rename' "Tls.Cipher" "io2.Tls.Cipher" , B' "TVar" CT.Data, Rename' "TVar" "io2.TVar" , B' "STM" CT.Effect, Rename' "STM" "io2.STM" + , B' "Ref" CT.Data + , B' "Scope" CT.Effect ] -- rename these to "builtin" later, when builtin means intrinsic as opposed to @@ -253,7 +256,8 @@ typeOf a f r = maybe a f (Map.lookup r termRefTypes) builtinsSrc :: Var v => [BuiltinDSL v] builtinsSrc = - [ B "Int.+" $ int --> int --> int + [ B "Any.unsafeExtract" $ forall1 "a" (\a -> anyt --> a) + , B "Int.+" $ int --> int --> int , B "Int.-" $ int --> int --> int , B "Int.*" $ int --> int --> int , B "Int./" $ int --> int --> int @@ -432,6 +436,11 @@ builtinsSrc = , B "Bytes.size" $ bytes --> nat , B "Bytes.flatten" $ bytes --> bytes + , B "Bytes.zlib.compress" $ bytes --> bytes + , B "Bytes.zlib.decompress" $ bytes --> eithert text bytes + , B "Bytes.gzip.compress" $ bytes --> bytes + , B "Bytes.gzip.decompress" $ bytes --> eithert text bytes + {- These are all `Bytes -> Bytes`, rather than `Bytes -> Text`. This is intentional: it avoids a round trip to `Text` if all you are doing with the bytes is dumping them to a file or a @@ -462,6 +471,17 @@ builtinsSrc = , B "List.at" $ forall1 "a" (\a -> nat --> list a --> optionalt a) , B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a) + , B "unsafe.coerceAbilities" $ + forall4 "a" "b" "e1" "e2" $ \a b e1 e2 -> + (a --> Type.effect1 () e1 b) --> (a --> Type.effect1 () e2 b) + , B "Scope.run" . forall2 "r" "g" $ \r g -> + (forall1 "s" $ \s -> unit --> Type.effect () [scopet s, g] r) --> Type.effect1 () g r + , B "Scope.ref" . forall2 "a" "s" $ \a s -> + a --> Type.effect1 () (scopet s) (reft (Type.effects () [scopet s]) a) + , B "Ref.read" . forall2 "a" "g" $ \a g -> + reft g a --> Type.effect1 () g a + , B "Ref.write" . forall2 "a" "g" $ \a g -> + reft g a --> a --> Type.effect1 () g unit ] ++ -- avoid name conflicts with Universal == < > <= >= [ Rename (t <> "." <> old) (t <> "." <> new) @@ -546,6 +566,7 @@ ioBuiltins = , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) , ("IO.systemTime.impl.v3", unit --> iof nat) + , ("IO.systemTimeMicroseconds.v1", unit --> io int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) @@ -573,6 +594,8 @@ ioBuiltins = , ("IO.delay.impl.v3", nat --> iof unit) , ("IO.kill.impl.v3", threadId --> iof unit) + , ("IO.ref", forall1 "a" $ \a -> + a --> io (reft (Type.effects () [Type.builtinIO ()]) a)) , ("Tls.newClient.impl.v3", tlsClientConfig --> socket --> iof tls) , ("Tls.newServer.impl.v3", tlsServerConfig --> socket --> iof tls) , ("Tls.handshake.impl.v3", tls --> iof unit) @@ -618,13 +641,16 @@ codeBuiltins = , ("Code.serialize", code --> bytes) , ("Code.deserialize", bytes --> eithert text code) , ("Code.cache_", list (tuple [termLink,code]) --> io (list termLink)) + , ("Code.validate", list (tuple [termLink,code]) --> io (optionalt failure)) , ("Code.lookup", termLink --> io (optionalt code)) + , ("Code.display", text --> code --> text) , ("Value.dependencies", value --> list termLink) , ("Value.serialize", value --> bytes) , ("Value.deserialize", bytes --> eithert text value) , ("Value.value", forall1 "a" $ \a -> a --> value) , ("Value.load" , forall1 "a" $ \a -> value --> io (eithert (list termLink) a)) + , ("Link.Term.toText", termLink --> text) ] stmBuiltins :: forall v. Var v => [(Text, Type v)] @@ -645,6 +671,31 @@ forall1 name body = a = Var.named name in Type.forall () a (body $ Type.var () a) +forall2 + :: Var v => Text -> Text -> (Type v -> Type v -> Type v) -> Type v +forall2 na nb body = Type.foralls () [a,b] (body ta tb) + where + a = Var.named na + b = Var.named nb + ta = Type.var () a + tb = Type.var () b + +forall4 + :: Var v + => Text -> Text -> Text -> Text + -> (Type v -> Type v -> Type v -> Type v -> Type v) + -> Type v +forall4 na nb nc nd body = Type.foralls () [a,b,c,d] (body ta tb tc td) + where + a = Var.named na + b = Var.named nb + c = Var.named nc + d = Var.named nd + ta = Type.var () a + tb = Type.var () b + tc = Type.var () c + td = Type.var () d + app :: Ord v => Type v -> Type v -> Type v app = Type.app () @@ -675,6 +726,12 @@ failure = DD.failureType () eithert :: Var v => Type v -> Type v -> Type v eithert l r = DD.eitherType () `app` l `app` r +scopet :: Var v => Type v -> Type v +scopet s = Type.scopeType () `app` s + +reft :: Var v => Type v -> Type v -> Type v +reft s a = Type.refType () `app` s `app` a + socket, threadId, handle, unit :: Var v => Type v socket = Type.socket () threadId = Type.threadId () diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index e30989ed4b..292b830098 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -4,7 +4,7 @@ module Unison.Builtin.Decls where -import Control.Lens (_3,over) +import Control.Lens (over, _3) import Data.List (elemIndex, find) import qualified Data.Map as Map import Data.Text (Text, unpack) @@ -13,16 +13,16 @@ import qualified Unison.ConstructorType as CT import Unison.DataDeclaration ( DataDeclaration (..), Modifier (Structural, Unique), - hashDecls, ) import qualified Unison.DataDeclaration as DD +import Unison.Hashing.V2.Convert (hashDecls) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import Unison.Referent (Referent) +import Unison.Referent (ConstructorId, Referent) import qualified Unison.Referent as Referent import Unison.Symbol (Symbol) -import Unison.Term (ConstructorId, Term, Term2) +import Unison.Term (Term, Term2) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type @@ -86,6 +86,7 @@ constructorId ref name = do noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId +seqViewEmpty, seqViewElem :: ConstructorId Just noneId = constructorId optionalRef "Optional.None" Just someId = constructorId optionalRef "Optional.Some" Just isPropagatedConstructorId = constructorId isPropagatedRef "IsPropagated.IsPropagated" @@ -102,6 +103,8 @@ Just linkTermId = constructorId linkRef "Link.Term" Just linkTypeId = constructorId linkRef "Link.Type" Just eitherRightId = constructorId eitherRef "Either.Right" Just eitherLeftId = constructorId eitherRef "Either.Left" +Just seqViewEmpty = constructorId seqViewRef "SeqView.VEmpty" +Just seqViewElem = constructorId seqViewRef "SeqView.VElem" Just bufferModeNoBufferingId = constructorId bufferModeRef "io2.BufferMode.NoBuffering" Just bufferModeLineBufferingId = constructorId bufferModeRef "io2.BufferMode.LineBuffering" diff --git a/parser-typechecker/src/Unison/Builtin/Terms.hs b/parser-typechecker/src/Unison/Builtin/Terms.hs index c51777a97a..9057c6d0cf 100644 --- a/parser-typechecker/src/Unison/Builtin/Terms.hs +++ b/parser-typechecker/src/Unison/Builtin/Terms.hs @@ -7,6 +7,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Unison.Builtin.Decls as Decls +import qualified Unison.Hashing.V2.Convert as H import qualified Unison.Reference as Reference import Unison.Term (Term) import qualified Unison.Term as Term @@ -31,6 +32,9 @@ v :: Var v => Text -> v v = Var.named builtinTermsRef :: Var v => a -> Map v Reference.Id -builtinTermsRef a = fmap fst . Term.hashComponents . Map.fromList +builtinTermsRef a = + fmap fst + . H.hashTermComponents + . Map.fromList . fmap (\(v, tm, _tp) -> (v, tm)) $ builtinTermsSrc a diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 8a7453e587..35f722e4ef 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,138 +1,74 @@ {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase where -import Control.Lens ((%=), _1, _2) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.State (State, evalState, get) -import Data.Bifunctor (bimap) +module Unison.Codebase + ( Codebase (..), + CodebasePath, + GetRootBranchError (..), + getBranchForHash, + getCodebaseDir, + isBlank, + SyncToDir, + addDefsToCodebase, + installUcmDependencies, + getTypeOfTerm, + getTypeOfReferent, + lca, + lookupWatchCache, + toCodeLookup, + typeLookupForDependencies, + importRemoteBranch, + viewRemoteBranch, + termsOfType, + termsMentioningType, + dependents, + isTerm, + isType, + ) +where + +import Control.Error (rightMay) import Control.Error.Util (hush) -import Data.Maybe as Maybe +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) import Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Unison.ABT as ABT +import U.Util.Timing (time) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import qualified Unison.Codebase.CodeLookup as CL import Unison.Codebase.Editor.Git (withStatus) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo) -import Unison.Codebase.GitError (GitError) -import Unison.Codebase.Patch (Patch) -import qualified Unison.Codebase.Reflog as Reflog -import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import qualified Unison.Codebase.GitError as GitError import Unison.Codebase.SyncMode (SyncMode) +import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), GitError (GitCodebaseError), SyncToDir) +import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as DD -import qualified Unison.Parser as Parser +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Parser.Ann as Parser import Unison.Prelude import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent -import Unison.ShortHash (ShortHash) import Unison.Symbol (Symbol) import Unison.Term (Term) -import qualified Unison.Term as Term import Unison.Type (Type) -import qualified Unison.Type as Type import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup)) import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.UnisonFile as UF import qualified Unison.Util.Relation as Rel -import qualified Unison.Util.Set as Set -import U.Util.Timing (time) import Unison.Var (Var) -import qualified Unison.Var as Var -import UnliftIO.Directory (getHomeDirectory) -import qualified Unison.Codebase.GitError as GitError - -type DataDeclaration v a = DD.DataDeclaration v a - -type EffectDeclaration v a = DD.EffectDeclaration v a - --- | this FileCodebase detail lives here, because the interface depends on it πŸ™ƒ -type CodebasePath = FilePath - -type SyncToDir m = - CodebasePath -> -- dest codebase - SyncMode -> - Branch m -> -- branch to sync to dest codebase - m () - --- | Abstract interface to a user's codebase. --- --- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. -data Codebase m v a = - Codebase { getTerm :: Reference.Id -> m (Maybe (Term v a)) - , getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)) - , getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)) - - , putTerm :: Reference.Id -> Term v a -> Type v a -> m () - , putTypeDeclaration :: Reference.Id -> Decl v a -> m () - - , getRootBranch :: m (Either GetRootBranchError (Branch m)) - , putRootBranch :: Branch m -> m () - , rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)) - , getBranchForHashImpl :: Branch.Hash -> m (Maybe (Branch m)) - , putBranch :: Branch m -> m () - , branchExists :: Branch.Hash -> m Bool - - , getPatch :: Branch.EditHash -> m (Maybe Patch) - , putPatch :: Branch.EditHash -> Patch -> m () - , patchExists :: Branch.EditHash -> m Bool - - , dependentsImpl :: Reference -> m (Set Reference.Id) - -- This copies all the dependencies of `b` from the specified Codebase into this one - , syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m () - -- This copies all the dependencies of `b` from this Codebase - , syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m () - , viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)) - , pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()) - - -- Watch expressions are part of the codebase, the `Reference.Id` is - -- the hash of the source of the watch expression, and the `Term v a` - -- is the evaluated result of the expression, decompiled to a term. - , watches :: UF.WatchKind -> m [Reference.Id] - , getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term v a)) - , putWatch :: UF.WatchKind -> Reference.Id -> Term v a -> m () - , clearWatches :: m () - - , getReflog :: m [Reflog.Entry] - , appendReflog :: Text -> Branch m -> Branch m -> m () - - -- list of terms of the given type - , termsOfTypeImpl :: Reference -> m (Set Referent.Id) - -- list of terms that mention the given type anywhere in their signature - , termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) - -- number of base58 characters needed to distinguish any two references in the codebase - , hashLength :: m Int - , termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - , typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - , termReferentsByPrefix :: ShortHash -> m (Set Referent.Id) - - , branchHashLength :: m Int - , branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) - - -- returns `Nothing` to not implemented, fallback to in-memory - -- also `Nothing` if no LCA - -- The result is undefined if the two hashes are not in the codebase. - -- Use `Codebase.lca` which wraps this in a nice API. - , lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)) - - -- `beforeImpl` returns `Nothing` if not implemented by the codebase - -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase - -- - -- Use `Codebase.before` which wraps this in a nice API. - , beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) - } +import qualified Unison.WatchKind as WK -- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep -- If not found, attempt to find it in the Codebase (sqlite) getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m)) -getBranchForHash codebase h = +getBranchForHash codebase h = let nestedChildrenForDepth depth b = if depth == 0 then [] @@ -144,7 +80,7 @@ getBranchForHash codebase h = find rb = List.find headHashEq (nestedChildrenForDepth 3 rb) in do rootBranch <- hush <$> getRootBranch codebase - case rootBranch of + case rootBranch of Just rb -> maybe (getBranchForHashImpl codebase h) (pure . Just) (find rb) Nothing -> getBranchForHashImpl codebase h @@ -160,36 +96,9 @@ lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = case lcaImpl co Nothing -> pure Nothing -- no common ancestor else Branch.lca b1 b2 -before :: Monad m => Codebase m v a -> Branch m -> Branch m -> m Bool -before code b1 b2 = case beforeImpl code of - Nothing -> Branch.before b1 b2 - Just before -> before' (branchExists code) before b1 b2 - -before' :: Monad m => (Branch.Hash -> m Bool) -> (Branch.Hash -> Branch.Hash -> m Bool) -> Branch m -> Branch m -> m Bool -before' branchExists before b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = - ifM - (branchExists h2) - (ifM - (branchExists h2) - (before h1 h2) - (pure False)) - (Branch.before b1 b2) - - -data GetRootBranchError - = NoRootBranch - | CouldntParseRootBranch String - | CouldntLoadRootBranch Branch.Hash - deriving Show - debug :: Bool debug = False -data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward - -getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath -getCodebaseDir = maybe getHomeDirectory pure - -- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m () installUcmDependencies c = do @@ -210,7 +119,9 @@ addDefsToCodebase c uf = do traverse_ goTerm (UF.hashTermsId uf) where goTerm t | debug && trace ("Codebase.addDefsToCodebase.goTerm " ++ show t) False = undefined - goTerm (r, tm, tp) = putTerm c r tm tp + goTerm (r, Nothing, tm, tp) = putTerm c r tm tp + goTerm (r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp + goTerm _ = pure () goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> m () goType _f pair | debug && trace ("Codebase.addDefsToCodebase.goType " ++ show pair) False = undefined goType f (ref, decl) = putTypeDeclaration c ref (f decl) @@ -227,8 +138,8 @@ getTypeOfConstructor _ r cid = lookupWatchCache :: (Monad m) => Codebase m v a -> Reference -> m (Maybe (Term v a)) lookupWatchCache codebase (Reference.DerivedId h) = do - m1 <- getWatch codebase UF.RegularWatch h - maybe (getWatch codebase UF.TestWatch h) (pure . Just) m1 + m1 <- getWatch codebase WK.RegularWatch h + maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1 lookupWatchCache _ Reference.Builtin{} = pure Nothing typeLookupForDependencies @@ -249,99 +160,9 @@ typeLookupForDependencies codebase s = do Nothing -> pure mempty go tl Reference.Builtin{} = pure tl -- codebase isn't consulted for builtins --- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? --- todo: add some tests on this guy? -transitiveDependencies - :: (Monad m, Var v) - => CL.CodeLookup v m a - -> Set Reference.Id - -> Reference.Id - -> m (Set Reference.Id) -transitiveDependencies code seen0 rid = if Set.member rid seen0 - then pure seen0 - else - let seen = Set.insert rid seen0 - getIds = Set.mapMaybe Reference.toId - in CL.getTerm code rid >>= \case - Just t -> - foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) - Nothing -> - CL.getTypeDeclaration code rid >>= \case - Nothing -> pure seen - Just (Left ed) -> foldM (transitiveDependencies code) - seen - (getIds $ DD.dependencies (DD.toDataDecl ed)) - Just (Right dd) -> foldM (transitiveDependencies code) - seen - (getIds $ DD.dependencies dd) - toCodeLookup :: Codebase m v a -> CL.CodeLookup v m a toCodeLookup c = CL.CodeLookup (getTerm c) (getTypeDeclaration c) --- Like the other `makeSelfContained`, but takes and returns a `UnisonFile`. --- Any watches in the input `UnisonFile` will be watches in the returned --- `UnisonFile`. -makeSelfContained' - :: forall m v a . (Monad m, Monoid a, Var v) - => CL.CodeLookup v m a - -> UF.UnisonFile v a - -> m (UF.UnisonFile v a) -makeSelfContained' code uf = do - let UF.UnisonFileId ds0 es0 bs0 ws0 = uf - deps0 = getIds . Term.dependencies . snd <$> (UF.allWatches uf <> bs0) - where getIds = Set.mapMaybe Reference.toId - -- transitive dependencies (from codebase) of all terms (including watches) in the UF - deps <- foldM (transitiveDependencies code) Set.empty (Set.unions deps0) - -- load all decls from deps list - decls <- fmap catMaybes - . forM (toList deps) - $ \rid -> fmap (rid, ) <$> CL.getTypeDeclaration code rid - -- partition the decls into effects and data - let es1 :: [(Reference.Id, DD.EffectDeclaration v a)] - ds1 :: [(Reference.Id, DD.DataDeclaration v a)] - (es1, ds1) = partitionEithers [ bimap (r,) (r,) d | (r, d) <- decls ] - -- load all terms from deps list - bs1 <- fmap catMaybes - . forM (toList deps) - $ \rid -> fmap (rid, ) <$> CL.getTerm code rid - let - allVars :: Set v - allVars = Set.unions - [ UF.allVars uf - , Set.unions [ DD.allVars dd | (_, dd) <- ds1 ] - , Set.unions [ DD.allVars (DD.toDataDecl ed) | (_, ed) <- es1 ] - , Set.unions [ Term.allVars tm | (_, tm) <- bs1 ] - ] - refVar :: Reference.Id -> State (Set v, Map Reference.Id v) v - refVar r = do - m <- snd <$> get - case Map.lookup r m of - Just v -> pure v - Nothing -> do - v <- ABT.freshenS' _1 (Var.refNamed (Reference.DerivedId r)) - _2 %= Map.insert r v - pure v - assignVars :: [(Reference.Id, b)] -> State (Set v, Map Reference.Id v) [(v, (Reference.Id, b))] - assignVars = traverse (\e@(r, _) -> (,e) <$> refVar r) - unref :: Term v a -> State (Set v, Map Reference.Id v) (Term v a) - unref = ABT.visit go where - go t@(Term.Ref' (Reference.DerivedId r)) = - Just (Term.var (ABT.annotation t) <$> refVar r) - go _ = Nothing - unrefb = traverse (\(v, tm) -> (v,) <$> unref tm) - pair :: forall f a b. Applicative f => f a -> f b -> f (a,b) - pair = liftA2 (,) - uf' = flip evalState (allVars, Map.empty) $ do - datas' <- Map.union ds0 . Map.fromList <$> assignVars ds1 - effects' <- Map.union es0 . Map.fromList <$> assignVars es1 - -- bs0 is terms from the input file - bs0' <- unrefb bs0 - ws0' <- traverse unrefb ws0 - -- bs1 is dependency terms - bs1' <- traverse (\(r, tm) -> refVar r `pair` unref tm) bs1 - pure $ UF.UnisonFileId datas' effects' (bs1' ++ bs0') ws0' - pure uf' - getTypeOfTerm :: (Applicative m, Var v, BuiltinAnnotation a) => Codebase m v a -> Reference -> m (Maybe (Type v a)) getTypeOfTerm _c r | debug && trace ("Codebase.getTypeOfTerm " ++ show r) False = undefined @@ -357,7 +178,7 @@ getTypeOfReferent c (Referent.Ref r) = getTypeOfTerm c r getTypeOfReferent c (Referent.Con r cid _) = getTypeOfConstructor c r cid --- The dependents of a builtin type is the set of builtin terms which +-- | The dependents of a builtin type includes the set of builtin terms which -- mention that type. dependents :: Functor m => Codebase m v a -> Reference -> m (Set Reference) dependents c r @@ -370,16 +191,14 @@ termsOfType c ty = Set.union (Rel.lookupDom r Builtin.builtinTermsByType) . Set.map (fmap Reference.DerivedId) <$> termsOfTypeImpl c r - where - r = Type.toReference ty + where r = Hashing.typeToReference ty termsMentioningType :: (Var v, Functor m) => Codebase m v a -> Type v a -> m (Set Referent.Referent) termsMentioningType c ty = Set.union (Rel.lookupDom r Builtin.builtinTermsByTypeMention) . Set.map (fmap Reference.DerivedId) <$> termsMentioningTypeImpl c r - where - r = Type.toReference ty + where r = Hashing.typeToReference ty -- todo: could have a way to look this up just by checking for a file rather than loading it isTerm :: (Applicative m, Var v, BuiltinAnnotation a) @@ -391,11 +210,10 @@ isType c r = case r of Reference.Builtin{} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r -class BuiltinAnnotation a where - builtinAnnotation :: a - -instance BuiltinAnnotation Parser.Ann where - builtinAnnotation = Parser.Intrinsic +isBlank :: Applicative m => Codebase m v a -> m Bool +isBlank codebase = do + root <- fromMaybe Branch.empty . rightMay <$> getRootBranch codebase + pure (root == Branch.empty) -- * Git stuff @@ -416,7 +234,7 @@ importRemoteBranch codebase ns mode = runExceptT do lift $ syncFromDirectory codebase cacheDir mode branch ExceptT let h = Branch.headHash branch - err = Left $ GitError.CouldntLoadSyncedBranch h + err = Left . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns h in time "load fresh local branch after sync" $ (getBranchForHash codebase h <&> maybe err Right) <* cleanup diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index f04851ab8a..5fbb1d5e99 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -7,108 +7,72 @@ module Unison.Codebase.Branch ( -- * Branch types Branch(..) + , BranchDiff(..) , UnwrappedBranch , Branch0(..) - , MergeMode(..) , Raw(..) , Star , Hash , EditHash , pattern Hash - - -- * Branch construction - , empty - , empty0 + -- * Branch construction , branch0 , one + , cons + , uncons + , empty + , empty0 + , discardHistory0 , toCausalRaw , transform - - -- * Branch history - -- ** History queries + -- * Branch tests , isEmpty , isEmpty0 , isOne + , before + , lca + -- * diff + , diff0 + -- * properties , head , headHash - , before - , before' - , findHistoricalHQs - , findHistoricalRefs - , findHistoricalRefs' - , namesDiff - -- ** History updates - , step - , stepEverywhere - , uncons - , merge - , merge' - , merge'' - - -- * Branch children - -- ** Children lenses , children - -- ** Children queries + , deepEdits' , toList0 + -- * step + , stepManyAt + , stepManyAtM + , stepManyAt0 + , stepEverywhere + -- * + , addTermName + , addTypeName + , deleteTermName + , deleteTypeName + , setChildBranch + , replacePatch + , deletePatch + , getMaybePatch + , getPatch + , modifyPatches + -- ** Children queries , getAt , getAt' , getAt0 - -- ** Children updates - , setChildBranch - , stepManyAt - , stepManyAt0 - , stepManyAtM - , modifyAtM , modifyAt - - -- * Branch terms/types/edits - -- ** Term/type/edits lenses + , modifyAtM + -- * Branch terms/types/edits + -- ** Term/type/edits lenses , terms , types , edits -- ** Term/type queries , deepReferents , deepTypeReferences - , toNames0 - -- ** Term/type updates - , addTermName - , addTypeName - , deleteTermName - , deleteTypeName - - - -- * Branch patches - -- ** Patch queries - , deepEdits' - , getPatch - , getMaybePatch - -- ** Patch updates - , replacePatch - , deletePatch - , modifyPatches - - -- * Branch serialization + -- * Branch serialization , cachedRead - , boundedCache , Cache , sync - - -- * Unused - , childrenR - , debugPaths - , editedPatchRemoved - , editsR - , findHistoricalSHs - , fork - , lca - , move - , numHashChars - , printDebugPaths - , removedPatchEdited - , stepAt - , stepAtM - , termsR - , typesR ) where import Unison.Prelude hiding (empty) @@ -140,27 +104,15 @@ import Unison.Hashable ( Hashable ) import qualified Unison.Hashable as H import Unison.Name ( Name(..) ) import qualified Unison.Name as Name -import qualified Unison.Names2 as Names -import qualified Unison.Names3 as Names -import Unison.Names2 ( Names'(Names), Names0 ) import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) -import qualified Unison.Referent as Referent -import qualified Unison.Reference as Reference import qualified U.Util.Cache as Cache import qualified Unison.Util.Relation as R import Unison.Util.Relation ( Relation ) import qualified Unison.Util.Relation4 as R4 -import qualified Unison.Util.List as List -import Unison.Util.Map ( unionWithM ) import qualified Unison.Util.Star3 as Star3 -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import qualified Unison.HashQualified as HQ -import Unison.HashQualified (HashQualified) -import qualified Unison.LabeledDependency as LD -import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.Util.List as List -- | A node in the Unison namespace hierarchy -- along with its history. @@ -171,7 +123,6 @@ type UnwrappedBranch m = Causal m Raw (Branch0 m) type Hash = Causal.RawHash Raw type EditHash = Hash.Hash --- Star3 r n Metadata.Type (Metadata.Type, Metadata.Value) type Star r n = Metadata.Star r n -- | A node in the Unison namespace hierarchy. @@ -233,70 +184,6 @@ data Raw = Raw makeLenses ''Branch makeLensesFor [("_edits", "edits")] ''Branch0 -makeLenses ''Raw - -toNames0 :: Branch0 m -> Names0 -toNames0 b = Names (R.swap . deepTerms $ b) - (R.swap . deepTypes $ b) - --- This stops searching for a given ShortHash once it encounters --- any term or type in any Branch0 that satisfies that ShortHash. -findHistoricalSHs - :: Monad m => Set ShortHash -> Branch m -> m (Set ShortHash, Names0) -findHistoricalSHs = findInHistory - (\sh r _n -> sh `SH.isPrefixOf` Referent.toShortHash r) - (\sh r _n -> sh `SH.isPrefixOf` Reference.toShortHash r) - --- This stops searching for a given HashQualified once it encounters --- any term or type in any Branch0 that satisfies that HashQualified. -findHistoricalHQs :: Monad m - => Set (HashQualified Name) - -> Branch m - -> m (Set (HashQualified Name), Names0) -findHistoricalHQs = findInHistory - (\hq r n -> HQ.matchesNamedReferent n r hq) - (\hq r n -> HQ.matchesNamedReference n r hq) - -findHistoricalRefs :: Monad m => Set LabeledDependency -> Branch m - -> m (Set LabeledDependency, Names0) -findHistoricalRefs = findInHistory - (\query r _n -> LD.fold (const False) (==r) query) - (\query r _n -> LD.fold (==r) (const False) query) - -findHistoricalRefs' :: Monad m => Set Reference -> Branch m - -> m (Set Reference, Names0) -findHistoricalRefs' = findInHistory - (\queryRef r _n -> r == Referent.Ref queryRef) - (\queryRef r _n -> r == queryRef) - -findInHistory :: forall m q. (Monad m, Ord q) - => (q -> Referent -> Name -> Bool) - -> (q -> Reference -> Name -> Bool) - -> Set q -> Branch m -> m (Set q, Names0) -findInHistory termMatches typeMatches queries b = - (Causal.foldHistoryUntil f (queries, mempty) . _history) b <&> \case - -- could do something more sophisticated here later to report that some SH - -- couldn't be found anywhere in the history. but for now, I assume that - -- the normal thing will happen when it doesn't show up in the namespace. - Causal.Satisfied (_, names) -> (mempty, names) - Causal.Unsatisfied (missing, names) -> (missing, names) - where - -- in order to not favor terms over types, we iterate through the ShortHashes, - -- for each `remainingQueries`, if we find a matching Referent or Reference, - -- we remove `q` from the accumulated `remainingQueries`, and add the Ref* to - -- the accumulated `names0`. - f acc@(remainingQueries, _) b0 = (acc', null remainingQueries') - where - acc'@(remainingQueries', _) = foldl' findQ acc remainingQueries - findQ :: (Set q, Names0) -> q -> (Set q, Names0) - findQ acc sh = - foldl' (doType sh) (foldl' (doTerm sh) acc - (R.toList $ deepTerms b0)) - (R.toList $ deepTypes b0) - doTerm q acc@(remainingSHs, names0) (r, n) = if termMatches q r n - then (Set.delete q remainingSHs, Names.addTerm n r names0) else acc - doType q acc@(remainingSHs, names0) (r, n) = if typeMatches q r n - then (Set.delete q remainingSHs, Names.addType n r names0) else acc deepReferents :: Branch0 m -> Set Referent deepReferents = R.dom . deepTerms @@ -361,6 +248,7 @@ head (Branch c) = Causal.head c headHash :: Branch m -> Hash headHash (Branch c) = Causal.currentHash c +-- | a version of `deepEdits` that returns the `m Patch` as well. deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) deepEdits' b = go id b where -- can change this to an actual prefix once Name is a [NameSegment] @@ -372,150 +260,33 @@ deepEdits' b = go id b where f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) -data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) - -merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) -merge = merge' RegularMerge - -- Discards the history of a Branch0's children, recursively discardHistory0 :: Applicative m => Branch0 m -> Branch0 m discardHistory0 = over children (fmap tweak) where tweak b = cons (discardHistory0 (head b)) empty -merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) -merge' = merge'' lca - -merge'' :: forall m . Monad m - => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator - -> MergeMode - -> Branch m - -> Branch m - -> m (Branch m) -merge'' _ _ b1 b2 | isEmpty b1 = pure b2 -merge'' _ mode b1 b2 | isEmpty b2 = case mode of - RegularMerge -> pure b1 - SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 -merge'' lca mode (Branch x) (Branch y) = - Branch <$> case mode of - RegularMerge -> Causal.threeWayMerge' lca' combine x y - SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y - where - lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) - combine Nothing l r = merge0 lca mode l r - combine (Just ca) l r = do - dl <- diff0 ca l - dr <- diff0 ca r - head0 <- apply ca (dl <> dr) - children <- Map.mergeA - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.zipWithAMatched $ const (merge'' lca mode)) - (_children l) (_children r) - pure $ branch0 (_terms head0) (_types head0) children (_edits head0) - - combineMissing ca k cur = - case Map.lookup k (_children ca) of - Nothing -> pure $ Just cur - Just old -> do - nw <- merge'' lca mode (cons empty0 old) cur - if isEmpty0 $ head nw - then pure Nothing - else pure $ Just nw - - apply :: Branch0 m -> BranchDiff -> m (Branch0 m) - apply b0 BranchDiff {..} = do - patches <- sequenceA - $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches - let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) - makePatch Patch.PatchDiff {..} = - let p = Patch.Patch _addedTermEdits _addedTypeEdits - in (H.accumulate' p, pure p) - pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) - (Star3.difference (_types b0) removedTypes <> addedTypes) - (_children b0) - (patches <> newPatches) - patchMerge mhp Patch.PatchDiff {..} = Just $ do - (_, mp) <- mhp - p <- mp - let np = Patch.Patch - { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits - <> _addedTermEdits - , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits - <> _addedTypeEdits - } - pure (H.accumulate' np, pure np) - --- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- It's defined as: lca b1 b2 == Just b1 -before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) - -> Branch m -> Branch m -> m Bool -before' lca (Branch x) (Branch y) = Causal.before' lca' x y - where - lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - -- `before b1 b2` is true if `b2` incorporates all of `b1` before :: Monad m => Branch m -> Branch m -> m Bool before (Branch b1) (Branch b2) = Causal.before b1 b2 -merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) - -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) -merge0 lca mode b1 b2 = do - c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) - e3 <- unionWithM g (_edits b1) (_edits b2) - pure $ branch0 (_terms b1 <> _terms b2) - (_types b1 <> _types b2) - c3 - e3 - where - g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) - g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) - g (_, m1) (_, m2) = do - e1 <- m1 - e2 <- m2 - let e3 = e1 <> e2 - pure (H.accumulate' e3, pure e3) - pattern Hash h = Causal.RawHash h +-- | what does this do? β€”AI toList0 :: Branch0 m -> [(Path, Branch0 m)] toList0 = go Path.empty where go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> go (Path.snoc p seg) (head cb) )) -printDebugPaths :: Branch m -> String -printDebugPaths = unlines . map show . Set.toList . debugPaths - -debugPaths :: Branch m -> Set (Path, Hash) -debugPaths = go Path.empty where - go p b = Set.insert (p, headHash b) . Set.unions $ - [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] - -data Target = TargetType | TargetTerm | TargetBranch - deriving (Eq, Ord, Show) - instance Eq (Branch0 m) where a == b = view terms a == view terms b && view types a == view types b && view children a == view children b && (fmap fst . view edits) a == (fmap fst . view edits) b -data ForkFailure = SrcNotFound | DestExists - --- consider delegating to Names.numHashChars when ready to implement? --- are those enough? --- could move this to a read-only field in Branch0 --- could move a Names0 to a read-only field in Branch0 until it gets too big -numHashChars :: Branch m -> Int -numHashChars _b = 3 - -- This type is a little ugly, so we wrap it up with a nice type alias for -- use outside this module. type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) -boundedCache :: MonadIO m => Word -> m (Cache m2) -boundedCache = Cache.semispaceCache - -- Can use `Cache.nullCache` to disable caching if needed cachedRead :: forall m . MonadIO m => Cache m @@ -596,52 +367,6 @@ toCausalRaw = \case Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) --- copy a path to another path -fork - :: Applicative m - => Path - -> Path - -> Branch m - -> Either ForkFailure (Branch m) -fork src dest root = case getAt src root of - Nothing -> Left SrcNotFound - Just src' -> case setIfNotExists dest src' root of - Nothing -> Left DestExists - Just root' -> Right root' - --- Move the node at src to dest. --- It's okay if `dest` is inside `src`, just create empty levels. --- Try not to `step` more than once at each node. -move :: Applicative m - => Path - -> Path - -> Branch m - -> Either ForkFailure (Branch m) -move src dest root = case getAt src root of - Nothing -> Left SrcNotFound - Just src' -> - -- make sure dest doesn't already exist - case getAt dest root of - Just _destExists -> Left DestExists - Nothing -> - -- find and update common ancestor of `src` and `dest`: - Right $ modifyAt ancestor go root - where - (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest - go = deleteAt relSrc . setAt relDest src' - -setIfNotExists - :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) -setIfNotExists dest b root = case getAt dest root of - Just _destExists -> Nothing - Nothing -> Just $ setAt dest b root - -setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m -setAt path b = modifyAt path (const b) - -deleteAt :: Applicative m => Path -> Branch m -> Branch m -deleteAt path = setAt path empty - -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` getAt :: Path -> Branch m @@ -699,30 +424,10 @@ uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) uncons (Branch b) = go <$> Causal.uncons b where go = over (_Just . _2) Branch --- Modify the branch0 at the head of at `path` with `f`, --- after creating it if necessary. Preserves history. -stepAt :: forall m. Applicative m - => Path - -> (Branch0 m -> Branch0 m) - -> Branch m -> Branch m -stepAt p f = modifyAt p g where - g :: Branch m -> Branch m - g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b - stepManyAt :: (Monad m, Foldable f) => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m stepManyAt actions = step (stepManyAt0 actions) --- Modify the branch0 at the head of at `path` with `f`, --- after creating it if necessary. Preserves history. -stepAtM :: forall n m. (Functor n, Applicative m) - => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) -stepAtM p f = modifyAtM p g where - g :: Branch m -> n (Branch m) - g (Branch b) = do - b0' <- f (Causal.head b) - pure $ Branch . Causal.consDistinct b0' $ b - stepManyAtM :: (Monad m, Monad n, Foldable f) => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) stepManyAtM actions = stepM (stepManyAt0M actions) @@ -846,10 +551,6 @@ instance Hashable (Branch0 m) where , H.accumulateToken (fst <$> _edits b) ] --- getLocalBranch :: Hash -> IO Branch --- getGithubBranch :: RemotePath -> IO Branch --- getLocalEdit :: GUID -> IO Patch - -- todo: consider inlining these into Actions2 addTermName :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m @@ -861,9 +562,6 @@ addTypeName addTypeName r new md = over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) --- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m --- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m - deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) = over terms (Star3.deletePrimaryD1 (r,n)) b @@ -874,9 +572,6 @@ deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) = over types (Star3.deletePrimaryD1 (r,n)) b deleteTypeName _ _ b = b -namesDiff :: Branch m -> Branch m -> Names.Diff -namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) - lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b @@ -911,30 +606,3 @@ transform f b = case _history b of -> Causal m Raw (Branch0 m) -> Causal m Raw (Branch0 n) transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) - -data BranchAttentions = BranchAttentions - { -- Patches that were edited on the right but entirely removed on the left. - removedPatchEdited :: [Name] - -- Patches that were edited on the left but entirely removed on the right. - , editedPatchRemoved :: [Name] - } - -instance Semigroup BranchAttentions where - BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 - = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - -instance Monoid BranchAttentions where - mempty = BranchAttentions [] [] - mappend = (<>) - -data RefCollisions = - RefCollisions { termCollisions :: Relation Name Name - , typeCollisions :: Relation Name Name - } deriving (Eq, Show) - -instance Semigroup RefCollisions where - (<>) = mappend -instance Monoid RefCollisions where - mempty = RefCollisions mempty mempty - mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) - (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs new file mode 100644 index 0000000000..99e9462ae4 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Unison.Codebase.Branch.Merge + ( MergeMode(..) + , merge'' + ) where + +import Unison.Prelude hiding (empty) +import Unison.Codebase.Branch + +import Prelude hiding (head, read, subtract) +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.Patch (Patch) +import qualified Unison.Codebase.Patch as Patch +import qualified Unison.Hashable as H +import Unison.Util.Map (unionWithM) +import qualified Unison.Util.Relation as R +import qualified Unison.Util.Star3 as Star3 + +data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) + +merge'' :: forall m . Monad m + => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator + -> MergeMode + -> Branch m + -> Branch m + -> m (Branch m) +merge'' _ _ b1 b2 | isEmpty b1 = pure b2 +merge'' _ mode b1 b2 | isEmpty b2 = case mode of + RegularMerge -> pure b1 + SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 +merge'' lca mode (Branch x) (Branch y) = + Branch <$> case mode of + RegularMerge -> Causal.threeWayMerge' lca' combine x y + SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y + where + lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) + combine Nothing l r = merge0 lca mode l r + combine (Just ca) l r = do + dl <- diff0 ca l + dr <- diff0 ca r + head0 <- apply ca (dl <> dr) + children <- Map.mergeA + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.zipWithAMatched $ const (merge'' lca mode)) + (_children l) (_children r) + pure $ branch0 (_terms head0) (_types head0) children (_edits head0) + + combineMissing ca k cur = + case Map.lookup k (_children ca) of + Nothing -> pure $ Just cur + Just old -> do + nw <- merge'' lca mode (cons empty0 old) cur + if isEmpty0 $ head nw + then pure Nothing + else pure $ Just nw + + apply :: Branch0 m -> BranchDiff -> m (Branch0 m) + apply b0 BranchDiff {..} = do + patches <- sequenceA + $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches + let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) + makePatch Patch.PatchDiff {..} = + let p = Patch.Patch _addedTermEdits _addedTypeEdits + in (H.accumulate' p, pure p) + pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) + (Star3.difference (_types b0) removedTypes <> addedTypes) + (_children b0) + (patches <> newPatches) + patchMerge mhp Patch.PatchDiff {..} = Just $ do + (_, mp) <- mhp + p <- mp + let np = Patch.Patch + { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits + <> _addedTermEdits + , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits + <> _addedTypeEdits + } + pure (H.accumulate' np, pure np) + +merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) + -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) +merge0 lca mode b1 b2 = do + c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) + e3 <- unionWithM g (_edits b1) (_edits b2) + pure $ branch0 (_terms b1 <> _terms b2) + (_types b1 <> _types b2) + c3 + e3 + where + g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) + g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) + g (_, m1) (_, m2) = do + e1 <- m1 + e2 <- m2 + let e3 = e1 <> e2 + pure (H.accumulate' e3, pure e3) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs new file mode 100644 index 0000000000..0667b7ffe8 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Branch.Names + ( findHistoricalHQs, + findHistoricalRefs, + findHistoricalRefs', + namesDiff, + toNames0, + ) +where + +import qualified Data.Set as Set +import Unison.Codebase.Branch +import qualified Unison.Codebase.Causal.FoldHistory as Causal +import Unison.HashQualified (HashQualified) +import qualified Unison.HashQualified as HQ +import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.LabeledDependency as LD +import Unison.Name (Name (..)) +import Unison.Names2 (Names' (Names), Names0) +import qualified Unison.Names2 as Names +import qualified Unison.Names3 as Names +import Unison.Prelude hiding (empty) +import Unison.Reference (Reference) +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent +import qualified Unison.Util.Relation as R +import Prelude hiding (head, read, subtract) + +toNames0 :: Branch0 m -> Names0 +toNames0 b = Names (R.swap . deepTerms $ b) + (R.swap . deepTypes $ b) + +-- This stops searching for a given HashQualified once it encounters +-- any term or type in any Branch0 that satisfies that HashQualified. +findHistoricalHQs :: Monad m + => Set (HashQualified Name) + -> Branch m + -> m (Set (HashQualified Name), Names0) +findHistoricalHQs = findInHistory + (\hq r n -> HQ.matchesNamedReferent n r hq) + (\hq r n -> HQ.matchesNamedReference n r hq) + +findHistoricalRefs :: Monad m => Set LabeledDependency -> Branch m + -> m (Set LabeledDependency, Names0) +findHistoricalRefs = findInHistory + (\query r _n -> LD.fold (const False) (==r) query) + (\query r _n -> LD.fold (==r) (const False) query) + +findHistoricalRefs' :: Monad m => Set Reference -> Branch m + -> m (Set Reference, Names0) +findHistoricalRefs' = findInHistory + (\queryRef r _n -> r == Referent.Ref queryRef) + (\queryRef r _n -> r == queryRef) + +findInHistory :: forall m q. (Monad m, Ord q) + => (q -> Referent -> Name -> Bool) + -> (q -> Reference -> Name -> Bool) + -> Set q -> Branch m -> m (Set q, Names0) +findInHistory termMatches typeMatches queries b = + (Causal.foldHistoryUntil f (queries, mempty) . _history) b <&> \case + -- could do something more sophisticated here later to report that some SH + -- couldn't be found anywhere in the history. but for now, I assume that + -- the normal thing will happen when it doesn't show up in the namespace. + Causal.Satisfied (_, names) -> (mempty, names) + Causal.Unsatisfied (missing, names) -> (missing, names) + where + -- in order to not favor terms over types, we iterate through the ShortHashes, + -- for each `remainingQueries`, if we find a matching Referent or Reference, + -- we remove `q` from the accumulated `remainingQueries`, and add the Ref* to + -- the accumulated `names0`. + f acc@(remainingQueries, _) b0 = (acc', null remainingQueries') + where + acc'@(remainingQueries', _) = foldl' findQ acc remainingQueries + findQ :: (Set q, Names0) -> q -> (Set q, Names0) + findQ acc sh = + foldl' (doType sh) (foldl' (doTerm sh) acc + (R.toList $ deepTerms b0)) + (R.toList $ deepTypes b0) + doTerm q acc@(remainingSHs, names0) (r, n) = if termMatches q r n + then (Set.delete q remainingSHs, Names.addTerm n r names0) else acc + doType q acc@(remainingSHs, names0) (r, n) = if typeMatches q r n + then (Set.delete q remainingSHs, Names.addType n r names0) else acc + +namesDiff :: Branch m -> Branch m -> Names.Diff +namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) diff --git a/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs new file mode 100644 index 0000000000..6a5769e8e3 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (..)) where + +import Unison.Parser.Ann (Ann) +import qualified Unison.Parser.Ann as Ann + +class BuiltinAnnotation a where + builtinAnnotation :: a + +instance BuiltinAnnotation Ann where + builtinAnnotation = Ann.Intrinsic diff --git a/parser-typechecker/src/Unison/Codebase/Causal.hs b/parser-typechecker/src/Unison/Codebase/Causal.hs index 08b14e9988..9317bd2863 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal.hs @@ -1,7 +1,32 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} -module Unison.Codebase.Causal where +module Unison.Codebase.Causal + ( Causal (..), + Raw (..), + RawHash (..), + one, + cons, + cons', + consDistinct, + uncons, + hash, + children, + Deserialize, + Serialize, + cachedRead, + threeWayMerge, + threeWayMerge', + squashMerge', + lca, + stepDistinct, + stepDistinctM, + sync, + transform, + unsafeMapHashPreserving, + before, + ) +where import Unison.Prelude @@ -65,27 +90,6 @@ data Causal m h e , tails :: Map (RawHash h) (m (Causal m h e)) } --- Convert the Causal to an adjacency matrix for debugging purposes. -toGraph - :: Monad m - => Set (RawHash h) - -> Causal m h e - -> m (Seq (RawHash h, RawHash h)) -toGraph seen c = case c of - One _ _ -> pure Seq.empty - Cons h1 _ (h2, m) -> if Set.notMember h1 seen - then do - tail <- m - g <- toGraph (Set.insert h1 seen) tail - pure $ (h1, h2) Seq.<| g - else pure Seq.empty - Merge h _ ts -> if Set.notMember h seen - then do - tails <- sequence $ Map.elems ts - gs <- Seq.fromList <$> traverse (toGraph (Set.insert h seen)) tails - pure $ Seq.fromList ((h, ) <$> Set.toList (Map.keysSet ts)) <> join gs - else pure Seq.empty - -- A serializer `Causal m h e`. Nonrecursive -- only responsible for -- writing a single node of the causal structure. data Raw h e @@ -93,17 +97,6 @@ data Raw h e | RawCons e (RawHash h) | RawMerge e (Set (RawHash h)) -rawHead :: Raw h e -> e -rawHead (RawOne e ) = e -rawHead (RawCons e _) = e -rawHead (RawMerge e _) = e - --- Don't need to deserialize the `e` to calculate `before`. -data Tails h - = TailsOne - | TailsCons (RawHash h) - | TailsMerge (Set (RawHash h)) - type Deserialize m h e = RawHash h -> m (Raw h e) cachedRead :: MonadIO m @@ -263,37 +256,15 @@ threeWayMerge' lca combine c1 c2 = do done newHead = Merge (RawHash (hash (newHead, Map.keys children))) newHead children -before' :: Monad m - => (Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))) - -> Causal m h e - -> Causal m h e - -> m Bool -before' lca a b = (== Just a) <$> lca a b - before :: Monad m => Causal m h e -> Causal m h e -> m Bool before a b = (== Just a) <$> lca a b hash :: Hashable e => e -> Hash hash = Hashable.accumulate' -step :: (Applicative m, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e -step f c = f (head c) `cons` c - stepDistinct :: (Applicative m, Eq e, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e stepDistinct f c = f (head c) `consDistinct` c -stepIf - :: (Applicative m, Hashable e) - => (e -> Bool) - -> (e -> e) - -> Causal m h e - -> Causal m h e -stepIf cond f c = if cond (head c) then step f c else c - -stepM - :: (Applicative m, Hashable e) => (e -> m e) -> Causal m h e -> m (Causal m h e) -stepM f c = (`cons` c) <$> f (head c) - stepDistinctM :: (Applicative m, Functor n, Eq e, Hashable e) => (e -> n e) -> Causal m h e -> n (Causal m h e) @@ -331,55 +302,3 @@ unsafeMapHashPreserving f c = case c of Merge h e tls -> Merge h (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq,Ord,Show) - --- foldHistoryUntil some condition on the accumulator is met, --- attempting to work backwards fairly through merge nodes --- (rather than following one back all the way to its root before working --- through others). Returns Unsatisfied if the condition was never satisfied, --- otherwise Satisfied. --- --- NOTE by RΓ“B: this short-circuits immediately and only looks at the first --- entry in the history, since this operation is far too slow to be practical. -foldHistoryUntil - :: forall m h e a - . (Monad m) - => (a -> e -> (a, Bool)) - -> a - -> Causal m h e - -> m (FoldHistoryResult a) -foldHistoryUntil f a c = step a mempty (pure c) where - step :: a -> Set (RawHash h) -> Seq (Causal m h e) -> m (FoldHistoryResult a) - step a _seen Seq.Empty = pure (Unsatisfied a) - step a seen (c Seq.:<| rest) | currentHash c `Set.member` seen = - step a seen rest - step a seen (c Seq.:<| rest) = case f a (head c) of - (a, True ) -> pure (Satisfied a) - (a, False) -> do - tails <- case c of - One{} -> pure mempty - Cons{} -> - let (_, t) = tail c - in --if h `Set.member` seen - if not (Set.null seen) then pure mempty else Seq.singleton <$> t - Merge{} -> - fmap Seq.fromList - . traverse snd - . filter (\(_, _) -> not (Set.null seen)) - . Map.toList - $ tails c - step a (Set.insert (currentHash c) seen) (rest <> tails) - -hashToRaw :: - forall m h e. Monad m => Causal m h e -> m (Map (RawHash h) [RawHash h]) -hashToRaw c = go mempty [c] where - go :: Map (RawHash h) [RawHash h] -> [Causal m h e] - -> m (Map (RawHash h) [RawHash h]) - go output [] = pure output - go output (c : queue) = case c of - One h _ -> go (Map.insert h [] output) queue - Cons h _ (htail, mctail) -> do - ctail <- mctail - go (Map.insert h [htail] output) (ctail : queue) - Merge h _ mtails -> do - tails <- sequence mtails - go (Map.insert h (Map.keys tails) output) (toList tails ++ queue) diff --git a/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs new file mode 100644 index 0000000000..44a88465ec --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} + +module Unison.Codebase.Causal.FoldHistory (FoldHistoryResult (..), foldHistoryUntil) where + +import Unison.Prelude + +import Unison.Codebase.Causal ( Causal(..), RawHash ) +import Prelude hiding (tail, head) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Map as Map + +data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq,Ord,Show) + +-- foldHistoryUntil some condition on the accumulator is met, +-- attempting to work backwards fairly through merge nodes +-- (rather than following one back all the way to its root before working +-- through others). Returns Unsatisfied if the condition was never satisfied, +-- otherwise Satisfied. +-- +-- NOTE by RΓ“B: this short-circuits immediately and only looks at the first +-- entry in the history, since this operation is far too slow to be practical. +foldHistoryUntil + :: forall m h e a + . (Monad m) + => (a -> e -> (a, Bool)) + -> a + -> Causal m h e + -> m (FoldHistoryResult a) +foldHistoryUntil f a c = step a mempty (pure c) where + step :: a -> Set (RawHash h) -> Seq (Causal m h e) -> m (FoldHistoryResult a) + step a _seen Seq.Empty = pure (Unsatisfied a) + step a seen (c Seq.:<| rest) | currentHash c `Set.member` seen = + step a seen rest + step a seen (c Seq.:<| rest) = case f a (head c) of + (a, True ) -> pure (Satisfied a) + (a, False) -> do + tails <- case c of + One{} -> pure mempty + Cons{} -> + let (_, t) = tail c + in --if h `Set.member` seen + if not (Set.null seen) then pure mempty else Seq.singleton <$> t + Merge{} -> + fmap Seq.fromList + . traverse snd + . filter (\(_, _) -> not (Set.null seen)) + . Map.toList + $ tails c + step a (Set.insert (currentHash c) seen) (rest <> tails) diff --git a/parser-typechecker/src/Unison/Codebase/Classes.hs b/parser-typechecker/src/Unison/Codebase/Classes.hs deleted file mode 100644 index afc6108da0..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Classes.hs +++ /dev/null @@ -1,40 +0,0 @@ - -module Unison.Codebase.Classes where --- ( GetDecls(..) --- , PutDecls(..) --- , GetBranch(..) --- , PutBranch(..) --- , GetDependents(..) --- ) where --- ---import Data.Set ( Set ) ---import Unison.Codebase.Branch ( Branch ) ---import Unison.DataDeclaration ( Decl ) ---import qualified Unison.Reference as Reference ---import Unison.Reference ( Reference ) ---import qualified Unison.Term as Term ---import qualified Unison.Type as Type ---import qualified Unison.Typechecker.TypeLookup as TL --- ---type Term v a = Term.AnnotatedTerm v a ---type Type v a = Type.AnnotatedType v a --- ---class GetDecls d m v a | d -> m v a where --- getTerm :: d -> Reference.Id -> m (Maybe (Term v a)) --- getTypeOfTerm :: d -> Reference -> m (Maybe (Type v a)) --- getTypeDeclaration :: d -> Reference.Id -> m (Maybe (Decl v a)) --- hasTerm :: d -> Reference.Id -> m Bool --- hasType :: d -> Reference.Id -> m Bool --- ---class PutDecls d m v a | d -> m v a where --- putTerm :: d -> Reference.Id -> Term v a -> Type v a -> m () --- putTypeDeclarationImpl :: d -> Reference.Id -> Decl v a -> m () --- ---class GetBranch b m | b -> m where --- getRootBranch :: b -> m (Branch m) --- ---class PutBranch b m | b -> m where --- putRootBranch :: b -> Branch m -> m () --- ---class GetDependents d m | d -> m where --- dependentsImpl :: d -> Reference -> m (Set Reference.Id) diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs index e283adbe71..e6026d268f 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs @@ -2,30 +2,15 @@ module Unison.Codebase.CodeLookup where import Unison.Prelude -import Control.Monad.Morph -import qualified Data.Map as Map -import Unison.UnisonFile ( UnisonFile ) -import qualified Unison.UnisonFile as UF -import qualified Unison.Term as Term -import Unison.Term ( Term ) -import Unison.Var ( Var ) +import Control.Monad.Morph (MFunctor (..)) +import qualified Data.Set as Set +import Unison.DataDeclaration (Decl) +import qualified Unison.DataDeclaration as DD import qualified Unison.Reference as Reference -import Unison.DataDeclaration (Decl) - -fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a -fromUnisonFile uf = CodeLookup tm ty where - tm id = pure $ Map.lookup id termMap - ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 - typeMap1 = Map.fromList [ (id, Right dd) | - (_, (Reference.DerivedId id, dd)) <- - Map.toList (UF.dataDeclarations uf) ] - typeMap2 = Map.fromList [ (id, Left ad) | - (_, (Reference.DerivedId id, ad)) <- - Map.toList (UF.effectDeclarations uf) ] - tmm = Map.fromList (UF.terms uf) - termMap = Map.fromList [ (id, e) | - (_, (id, e)) <- - Map.toList (Term.hashComponents tmm) ] +import Unison.Term (Term) +import qualified Unison.Term as Term +import qualified Unison.Util.Set as Set +import Unison.Var (Var) data CodeLookup v m a = CodeLookup { @@ -55,3 +40,29 @@ instance Monad m => Monoid (CodeLookup v m a) where ty id = do o <- getTypeDeclaration c1 id case o of Nothing -> getTypeDeclaration c2 id; Just _ -> pure o + +-- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? +-- todo: add some tests on this guy? +transitiveDependencies + :: (Monad m, Var v) + => CodeLookup v m a + -> Set Reference.Id + -> Reference.Id + -> m (Set Reference.Id) +transitiveDependencies code seen0 rid = if Set.member rid seen0 + then pure seen0 + else + let seen = Set.insert rid seen0 + getIds = Set.mapMaybe Reference.toId + in getTerm code rid >>= \case + Just t -> + foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) + Nothing -> + getTypeDeclaration code rid >>= \case + Nothing -> pure seen + Just (Left ed) -> foldM (transitiveDependencies code) + seen + (getIds $ DD.dependencies (DD.toDataDecl ed)) + Just (Right dd) -> foldM (transitiveDependencies code) + seen + (getIds $ DD.dependencies dd) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs new file mode 100644 index 0000000000..0f33aad54b --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Unison.Codebase.CodeLookup.Util where + +import qualified Data.Map as Map +import Unison.Codebase.CodeLookup +import qualified Unison.DataDeclaration as DataDeclaration +import Unison.Prelude +import qualified Unison.Reference as Reference +import qualified Unison.Term as Term +import qualified Unison.UnisonFile as UF +import Unison.UnisonFile.Type (TypecheckedUnisonFile) +import Unison.Var (Var) + +fromTypecheckedUnisonFile :: forall m v a. (Var v, Monad m) => TypecheckedUnisonFile v a -> CodeLookup v m a +fromTypecheckedUnisonFile tuf = CodeLookup tm ty + where + tm :: Reference.Id -> m (Maybe (Term.Term v a)) + tm id = pure $ Map.lookup id termMap + ty :: Reference.Id -> m (Maybe (DataDeclaration.Decl v a)) + ty id = pure $ Map.lookup id dataDeclMap <|> Map.lookup id effectDeclMap + dataDeclMap = + Map.fromList + [ (id, Right dd) + | (_, (Reference.DerivedId id, dd)) <- + Map.toList (UF.dataDeclarations' tuf) + ] + effectDeclMap = + Map.fromList + [ (id, Left ad) + | (_, (Reference.DerivedId id, ad)) <- + Map.toList (UF.effectDeclarations' tuf) + ] + termMap :: Map Reference.Id (Term.Term v a) + termMap = Map.fromList [(id, tm) | (id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf] diff --git a/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs b/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs index 8ef7a60c87..7e56721cca 100644 --- a/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs +++ b/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs @@ -64,10 +64,10 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type -import Unison.UnisonFile (WatchKind) import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as Relation import Unison.Util.Star3 (Star3 (Star3)) +import Unison.WatchKind (WatchKind) debug :: Bool debug = False diff --git a/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs b/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs deleted file mode 100644 index f789c02af2..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.Conversion.Upgrade12 where - -import Control.Exception.Safe (MonadCatch) -import Control.Lens (Lens', (&), (.~), (^.)) -import qualified Control.Lens as Lens -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import qualified Control.Monad.Reader as Reader -import Control.Monad.State (StateT (StateT, runStateT)) -import qualified Control.Monad.State as State -import Control.Monad.Trans (lift) -import qualified Data.Map as Map -import qualified U.Codebase.Sync as Sync -import Unison.Codebase (CodebasePath) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch (Branch (Branch)) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Conversion.Sync12 as Sync12 -import qualified Unison.Codebase.FileCodebase as FC -import qualified Unison.Codebase.Init as Codebase -import qualified Unison.Codebase.SqliteCodebase as SC -import qualified Unison.PrettyTerminal as CT -import Unison.UnisonFile (WatchKind) -import qualified Unison.UnisonFile as WK -import UnliftIO (MonadIO, liftIO) - -syncWatchKinds :: [WatchKind] -syncWatchKinds = [WK.TestWatch] - -upgradeCodebase :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m () -upgradeCodebase root = do - either (liftIO . CT.putPrettyLn) pure =<< runExceptT do - (cleanupSrc, srcCB) <- ExceptT $ Codebase.openCodebase FC.init "upgradeCodebase srcCB" root - (cleanupDest, destCB) <- ExceptT $ Codebase.createCodebase SC.init "upgradeCodebase destCB" root - destDB <- SC.unsafeGetConnection "upgradeCodebase destDB" root - let env = Sync12.Env srcCB destCB destDB - let initialState = (Sync12.emptyDoneCount, Sync12.emptyErrorCount, Sync12.emptyStatus) - rootEntity <- - lift (Codebase.getRootBranch srcCB) >>= \case - Left e -> error $ "Error loading source codebase root branch: " ++ show e - Right (Branch c) -> pure $ Sync12.C (Causal.currentHash c) (pure c) - watchResults <- - lift $ - concat - <$> traverse - (\k -> fmap (Sync12.W k) <$> Codebase.watches srcCB k) - syncWatchKinds - (_, _, s) <- flip Reader.runReaderT env . flip State.execStateT initialState $ do - sync <- Sync12.sync12 (lift . lift . lift) - Sync.sync @_ @(Sync12.Entity _) - (Sync.transformSync (lensStateT Lens._3) sync) - Sync12.simpleProgress - (rootEntity : watchResults) - lift $ - Codebase.putRootBranch destCB =<< fmap Branch case rootEntity of - Sync12.C h mc -> case Map.lookup h (Sync12._branchStatus s) of - Just Sync12.BranchOk -> mc - Just (Sync12.BranchReplaced _h' c') -> pure c' - Nothing -> error "We didn't sync the root?" - _ -> error "The root wasn't a causal?" - SC.shutdownConnection destDB - lift cleanupSrc - lift cleanupDest - pure () - where - lensStateT :: forall m s1 s2 a. Monad m => Lens' s2 s1 -> StateT s1 m a -> StateT s2 m a - lensStateT l m = StateT \s2 -> do - (a, s1') <- runStateT m (s2 ^. l) - pure (a, s2 & l .~ s1') diff --git a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs index de6cb47d6f..638d672187 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs @@ -2,58 +2,68 @@ module Unison.Codebase.Editor.AuthorInfo where -import Unison.Term (Term, hashComponents) - -import qualified Unison.Reference as Reference -import Unison.Prelude (MonadIO, Word8) -import Unison.Var (Var) -import Data.ByteString (unpack) import Crypto.Random (getRandomBytes) +import Data.ByteString (unpack) +import qualified Data.Foldable as Foldable import qualified Data.Map as Map -import qualified Unison.Var as Var -import Data.Foldable (toList) -import UnliftIO (liftIO) +import Data.Text (Text) +import qualified Unison.Hashing.V2.Convert as H +import Unison.Prelude (MonadIO, Word8) +import qualified Unison.Reference as Reference +import Unison.Term (Term) import qualified Unison.Term as Term -import qualified Unison.Type as Type import Unison.Type (Type) -import Data.Text (Text) +import qualified Unison.Type as Type +import Unison.Var (Var) +import qualified Unison.Var as Var +import UnliftIO (liftIO) data AuthorInfo v a = AuthorInfo - { guid, author, copyrightHolder :: (Reference.Id, Term v a, Type v a) } + {guid, author, copyrightHolder :: (Reference.Id, Term v a, Type v a)} createAuthorInfo :: forall m v a. MonadIO m => Var v => a -> Text -> m (AuthorInfo v a) createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32) where - createAuthorInfo' :: [Word8] -> AuthorInfo v a - createAuthorInfo' bytes = let - [(guidRef, guidTerm)] = hashAndWrangle "guid" $ - Term.app a - (Term.constructor a guidTypeRef 0) - (Term.app a - (Term.builtin a "Bytes.fromList") - (Term.list a (map (Term.nat a . fromIntegral) bytes))) - - [(authorRef, authorTerm)] = hashAndWrangle "author" $ - Term.apps - (Term.constructor a authorTypeRef 0) - [(a, Term.ref a (Reference.DerivedId guidRef)) - ,(a, Term.text a t)] + createAuthorInfo' :: [Word8] -> AuthorInfo v a + createAuthorInfo' bytes = + let [(guidRef, guidTerm)] = + hashAndWrangle "guid" $ + Term.app + a + (Term.constructor a guidTypeRef 0) + ( Term.app + a + (Term.builtin a "Bytes.fromList") + (Term.list a (map (Term.nat a . fromIntegral) bytes)) + ) - [(chRef, chTerm)] = hashAndWrangle "copyrightHolder" $ - Term.apps - (Term.constructor a chTypeRef 0) - [(a, Term.ref a (Reference.DerivedId guidRef)) - ,(a, Term.text a t)] + [(authorRef, authorTerm)] = + hashAndWrangle "author" $ + Term.apps + (Term.constructor a authorTypeRef 0) + [ (a, Term.ref a (Reference.DerivedId guidRef)), + (a, Term.text a t) + ] - in AuthorInfo - (guidRef, guidTerm, guidType) - (authorRef, authorTerm, authorType) - (chRef, chTerm, chType) - hashAndWrangle v tm = toList . hashComponents $ Map.fromList [(Var.named v, tm)] - (chType, chTypeRef) = (Type.ref a chTypeRef, unsafeParse copyrightHolderHash) - (authorType, authorTypeRef) = (Type.ref a authorTypeRef, unsafeParse authorHash) - (guidType, guidTypeRef) = (Type.ref a guidTypeRef, unsafeParse guidHash) - unsafeParse = either error id . Reference.fromText - guidHash = "#rc29vdqe019p56kupcgkg07fkib86r3oooatbmsgfbdsgpmjhsh00l307iuts3r973q5etb61vbjkes42b6adb3mkorusvmudiuorno" - copyrightHolderHash = "#aohndsu9bl844vspujp142j5aijv86rifmnrbnjvpv3h3f3aekn45rj5s1uf1ucrrtm5urbc5d1ajtm7lqq1tr8lkgv5fathp6arqug" - authorHash = "#5hi1vvs5t1gmu6vn1kpqmgksou8ie872j31gc294lgqks71di6gm3d4ugnrr4mq8ov0ap1e20lq099d5g6jjf9c6cbp361m9r9n5g50" + [(chRef, chTerm)] = + hashAndWrangle "copyrightHolder" $ + Term.apps + (Term.constructor a chTypeRef 0) + [ (a, Term.ref a (Reference.DerivedId guidRef)), + (a, Term.text a t) + ] + in AuthorInfo + (guidRef, guidTerm, guidType) + (authorRef, authorTerm, authorType) + (chRef, chTerm, chType) + hashAndWrangle v tm = + Foldable.toList $ + H.hashTermComponents + (Map.fromList [(Var.named v, tm)]) + (chType, chTypeRef) = (Type.ref a chTypeRef, unsafeParse copyrightHolderHash) + (authorType, authorTypeRef) = (Type.ref a authorTypeRef, unsafeParse authorHash) + (guidType, guidTypeRef) = (Type.ref a guidTypeRef, unsafeParse guidHash) + unsafeParse = either error id . Reference.fromText + guidHash = "#rc29vdqe019p56kupcgkg07fkib86r3oooatbmsgfbdsgpmjhsh00l307iuts3r973q5etb61vbjkes42b6adb3mkorusvmudiuorno" + copyrightHolderHash = "#aohndsu9bl844vspujp142j5aijv86rifmnrbnjvpv3h3f3aekn45rj5s1uf1ucrrtm5urbc5d1ajtm7lqq1tr8lkgv5fathp6arqug" + authorHash = "#5hi1vvs5t1gmu6vn1kpqmgksou8ie872j31gc294lgqks71di6gm3d4ugnrr4mq8ov0ap1e20lq099d5g6jjf9c6cbp361m9r9n5g50" diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index 3feccc057f..dc3889a687 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -31,11 +31,11 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Branch ( Branch ) import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.GitError +import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.SyncMode ( SyncMode ) import Unison.Names3 ( Names, Names0 ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import Unison.Referent ( Referent ) import Unison.Reference ( Reference ) import Unison.Result ( Note @@ -60,6 +60,8 @@ import Unison.Name (Name) import Unison.Server.QueryResult (QueryResult) import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.WatchKind as WK +import Unison.Codebase.Type (GitError) type AmbientAbilities v = [Type v Ann] type SourceName = Text @@ -162,10 +164,10 @@ data Command m i v a where Evaluate1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> Command m i v (Either Runtime.Error (Term v Ann)) -- Add a cached watch to the codebase - PutWatch :: UF.WatchKind -> Reference.Id -> Term v Ann -> Command m i v () + PutWatch :: WK.WatchKind -> Reference.Id -> Term v Ann -> Command m i v () -- Loads any cached watches of the given kind - LoadWatches :: UF.WatchKind -> Set Reference -> Command m i v [(Reference, Term v Ann)] + LoadWatches :: WK.WatchKind -> Set Reference -> Command m i v [(Reference, Term v Ann)] -- Loads a root branch from some codebase, returning `Nothing` if not found. -- Any definitions in the head of the requested root that aren't in the local @@ -198,7 +200,7 @@ data Command m i v a where AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v () -- load the reflog in file (chronological) order - LoadReflog :: Command m i v [Reflog.Entry] + LoadReflog :: Command m i v [Reflog.Entry Branch.Hash] LoadTerm :: Reference.Id -> Command m i v (Maybe (Term v Ann)) @@ -239,7 +241,7 @@ type UseCache = Bool type EvalResult v = ( [(v, Term v ())] - , Map v (Ann, UF.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit) + , Map v (Ann, WK.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit) ) lookupEvalResult :: Ord v => v -> EvalResult v -> Maybe (Term v ()) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 7184c5d95a..18ab1153f5 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Editor.Git where +module Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch, withIOError, withStatus) where import Unison.Prelude @@ -11,16 +11,16 @@ import qualified Data.Text as Text import Shellmet (($?), ($^), ($|)) import System.FilePath (()) import Unison.Codebase.Editor.RemoteRepo (ReadRepo (ReadGitRepo)) -import Unison.Codebase.GitError (GitError) import qualified Unison.Codebase.GitError as GitError +import Unison.CodebasePath (CodebasePath) import qualified Unison.Util.Exception as Ex import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory, removeDirectoryRecursive) import UnliftIO.IO (hFlush, stdout) import qualified Data.ByteString.Base16 as ByteString import qualified Data.Char as Char import Control.Exception.Safe (catchIO, MonadCatch) +import Unison.Codebase.GitError (GitProtocolError) -type CodebasePath = FilePath -- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os encodeFileName :: String -> FilePath @@ -56,7 +56,7 @@ withStatus str ma = do -- | Given a remote git repo url, and branch/commit hash (currently -- not allowed): checks for git, clones or updates a cached copy of the repo -pullBranch :: (MonadIO m, MonadCatch m, MonadError GitError m) => ReadRepo -> m CodebasePath +pullBranch :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m) => ReadRepo -> m CodebasePath pullBranch repo@(ReadGitRepo uri) = do checkForGit localPath <- tempGitDir uri @@ -64,14 +64,14 @@ pullBranch repo@(ReadGitRepo uri) = do -- try to update existing directory (ifM (isGitRepo localPath) (checkoutExisting localPath) - (throwError (GitError.UnrecognizableCacheDir uri localPath))) + (throwError (GitError.UnrecognizableCacheDir repo localPath))) -- directory doesn't exist, so clone anew (checkOutNew localPath Nothing) pure localPath where -- | Do a `git clone` (for a not-previously-cached repo). - checkOutNew :: (MonadIO m, MonadError GitError m) => CodebasePath -> Maybe Text -> m () + checkOutNew :: (MonadIO m, MonadError GitProtocolError m) => CodebasePath -> Maybe Text -> m () checkOutNew localPath branch = do withStatus ("Downloading from " ++ Text.unpack uri ++ " ...") $ (liftIO $ @@ -80,10 +80,10 @@ pullBranch repo@(ReadGitRepo uri) = do ++ [uri, Text.pack localPath])) `withIOError` (throwError . GitError.CloneException repo . show) isGitDir <- liftIO $ isGitRepo localPath - unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir uri localPath + unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath -- | Do a `git pull` on a cached repo. - checkoutExisting :: (MonadIO m, MonadCatch m, MonadError GitError m) => FilePath -> m () + checkoutExisting :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m) => FilePath -> m () checkoutExisting localPath = ifM (isEmptyGitRepo localPath) -- I don't know how to properly update from an empty remote repo. @@ -99,7 +99,7 @@ pullBranch repo@(ReadGitRepo uri) = do (const $ goFromScratch)) where - goFromScratch :: (MonadIO m, MonadError GitError m) => m () + goFromScratch :: (MonadIO m, MonadError GitProtocolError m) => m () goFromScratch = do wipeDir localPath; checkOutNew localPath Nothing isEmptyGitRepo :: MonadIO m => FilePath -> m Bool @@ -113,11 +113,11 @@ pullBranch repo@(ReadGitRepo uri) = do e <- Ex.tryAny . whenM (doesDirectoryExist localPath) $ removeDirectoryRecursive localPath case e of - Left e -> throwError (GitError.SomeOtherError (show e)) + Left e -> throwError (GitError.CleanupError e) Right _ -> pure () -- | See if `git` is on the system path. -checkForGit :: MonadIO m => MonadError GitError m => m () +checkForGit :: MonadIO m => MonadError GitProtocolError m => m () checkForGit = do gitPath <- liftIO $ findExecutable "git" when (isNothing gitPath) $ throwError GitError.NoGit diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index 2c4c8dcf9a..44322edfb1 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -9,43 +9,43 @@ module Unison.Codebase.Editor.HandleCommand where import Unison.Prelude -import Unison.Codebase.Editor.Output -import Unison.Codebase.Editor.Command - -import qualified Unison.Builtin as B - -import qualified Unison.Server.Backend as Backend -import qualified Crypto.Random as Random -import Control.Monad.Except ( runExceptT ) -import qualified Control.Monad.State as State -import qualified Data.Configurator as Config -import Data.Configurator.Types ( Config ) -import qualified Data.Map as Map -import qualified Data.Text as Text -import Unison.Codebase ( Codebase ) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch ( Branch ) -import qualified Unison.Codebase.Branch as Branch -import Unison.Parser ( Ann ) -import qualified Unison.Parser as Parser -import qualified Unison.Parsers as Parsers -import qualified Unison.Reference as Reference -import qualified Unison.Codebase.Runtime as Runtime -import Unison.Codebase.Runtime (Runtime) -import qualified Unison.Server.CodebaseServer as Server -import qualified Unison.Term as Term -import qualified Unison.UnisonFile as UF -import Unison.Util.Free ( Free ) -import qualified Unison.Util.Free as Free -import Unison.Var ( Var ) +import Control.Monad.Except (runExceptT) +import qualified Control.Monad.State as State +import qualified Crypto.Random as Random +import qualified Data.Configurator as Config +import Data.Configurator.Types (Config) +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Unison.Builtin as B +import Unison.Codebase (Codebase) +import qualified Unison.Codebase as Codebase +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) +import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) +import Unison.Codebase.Runtime (Runtime) +import qualified Unison.Codebase.Runtime as Runtime +import Unison.FileParsers (parseAndSynthesizeFile, synthesizeFile') +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Parser as Parser +import Unison.Parser.Ann (Ann) +import qualified Unison.Parser.Ann as Ann +import qualified Unison.Parsers as Parsers +import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.Reference as Reference import qualified Unison.Result as Result -import Unison.FileParsers ( parseAndSynthesizeFile - , synthesizeFile' - ) -import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.Server.Backend as Backend +import qualified Unison.Server.CodebaseServer as Server import Unison.Term (Term) +import qualified Unison.Term as Term import Unison.Type (Type) -import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo +import qualified Unison.UnisonFile as UF +import Unison.Util.Free (Free) +import qualified Unison.Util.Free as Free +import Unison.Var (Var) +import qualified Unison.WatchKind as WK import Web.Browser (openBrowser) typecheck @@ -97,7 +97,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour go x = case x of -- Wait until we get either user input or a unison file update Eval m -> lift m - UI -> + UI -> case serverBaseUrl of Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url) Nothing -> lift (return ()) @@ -177,7 +177,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour lift $ evalUnisonFile ppe uf AppendToReflog reason old new -> lift $ Codebase.appendReflog codebase reason old new LoadReflog -> lift $ Codebase.getReflog codebase - CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Parser.External t + CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Ann.External t HQNameQuery mayPath branch query -> lift $ Backend.hqNameQuery mayPath branch codebase query LoadSearchResults srs -> lift $ Backend.loadSearchResults codebase srs @@ -187,8 +187,8 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour ClearWatchCache -> lift $ Codebase.clearWatches codebase watchCache (Reference.DerivedId h) = do - m1 <- Codebase.getWatch codebase UF.RegularWatch h - m2 <- maybe (Codebase.getWatch codebase UF.TestWatch h) (pure . Just) m1 + m1 <- Codebase.getWatch codebase WK.RegularWatch h + m2 <- maybe (Codebase.getWatch codebase WK.TestWatch h) (pure . Just) m1 pure $ Term.amap (const ()) <$> m2 watchCache Reference.Builtin{} = pure Nothing @@ -198,19 +198,15 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour cache = if useCache then watchCache else Runtime.noCache r <- Runtime.evaluateTerm' codeLookup cache ppe rt tm when useCache $ case r of - Right tmr -> Codebase.putWatch codebase UF.RegularWatch (Term.hashClosedTerm tm) - (Term.amap (const Parser.External) tmr) + Right tmr -> Codebase.putWatch codebase WK.RegularWatch (Hashing.hashClosedTerm tm) + (Term.amap (const Ann.External) tmr) Left _ -> pure () - pure $ r <&> Term.amap (const Parser.External) + pure $ r <&> Term.amap (const Ann.External) evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> _ - evalUnisonFile ppe (UF.discardTypes -> unisonFile) = do + evalUnisonFile ppe unisonFile = do let codeLookup = Codebase.toCodeLookup codebase - evalFile <- - if Runtime.needsContainment rt - then Codebase.makeSelfContained' codeLookup unisonFile - else pure unisonFile - r <- Runtime.evaluateWatches codeLookup ppe watchCache rt evalFile + r <- Runtime.evaluateWatches codeLookup ppe watchCache rt unisonFile case r of Left e -> pure (Left e) Right rs@(_,map) -> do @@ -218,7 +214,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour if isHit then pure () else case hash of Reference.DerivedId h -> do - let value' = Term.amap (const Parser.External) value + let value' = Term.amap (const Ann.External) value Codebase.putWatch codebase kind h value' Reference.Builtin{} -> pure () pure $ Right rs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 1549128e3d..e89988906a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -60,6 +60,8 @@ import Unison.Codebase.Branch ( Branch(..) , Branch0(..) ) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.BranchUtil as BranchUtil import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN @@ -69,6 +71,7 @@ import qualified Unison.Codebase.Patch as Patch import Unison.Codebase.Path ( Path , Path'(..) ) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Reflog as Reflog import Unison.Server.SearchResult ( SearchResult ) import qualified Unison.Server.SearchResult as SR @@ -86,7 +89,7 @@ import Unison.Names3 ( Names(..), Names0 , pattern Names0 ) import qualified Unison.Names2 as Names import qualified Unison.Names3 as Names3 -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann(..)) import Unison.Reference ( Reference(..) ) import qualified Unison.Reference as Reference import Unison.Referent ( Referent ) @@ -96,8 +99,10 @@ import qualified Unison.ShortHash as SH import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.Type as Type +import qualified Unison.Type.Names as Type import qualified Unison.Result as Result import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF import qualified Unison.Util.Find as Find import Unison.Util.Free ( Free ) import qualified Unison.Util.Free as Free @@ -111,8 +116,13 @@ import qualified Unison.Var as Var import qualified Unison.Codebase.TypeEdit as TypeEdit import Unison.Codebase.TermEdit (TermEdit(..)) import qualified Unison.Codebase.TermEdit as TermEdit +import qualified Unison.Codebase.TermEdit.Typing as TermEdit import qualified Unison.Typechecker as Typechecker +import qualified Unison.WatchKind as WK import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.PrettyPrintEnvDecl.Names as PPE import Unison.Runtime.IOSource ( isTest ) import qualified Unison.Runtime.IOSource as IOSource import qualified Unison.Util.Monoid as Monoid @@ -139,6 +149,8 @@ import qualified Unison.Util.Relation as Relation import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Unison.Codebase.Editor.AuthorInfo (AuthorInfo(..)) +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Codebase.Verbosity as Verbosity type F m i v = Free (Command m i v) @@ -418,7 +430,7 @@ loop = do UpdateBuiltinsI -> "builtins.update" MergeBuiltinsI -> "builtins.merge" MergeIOBuiltinsI -> "builtins.mergeio" - PullRemoteBranchI orepo dest _syncMode -> + PullRemoteBranchI orepo dest _syncMode _ -> (Text.pack . InputPattern.patternName $ InputPatterns.patternFromInput input) <> " " @@ -427,6 +439,7 @@ loop = do (uncurry3 printNamespace) orepo <> " " <> p' dest + CreateMessage{} -> wat LoadI{} -> wat PreviewAddI{} -> wat PreviewUpdateI{} -> wat @@ -443,6 +456,7 @@ loop = do PreviewMergeLocalBranchI{} -> wat DiffNamespaceI{} -> wat SwitchBranchI{} -> wat + UpI{} -> wat PopBranchI{} -> wat NamesI{} -> wat TodoI{} -> wat @@ -461,7 +475,6 @@ loop = do ShowDefinitionByPrefixI{} -> wat ShowReflogI{} -> wat DebugNumberedArgsI{} -> wat - DebugBranchHistoryI{} -> wat DebugTypecheckedUnisonFileI{} -> wat DebugDumpNamespacesI{} -> wat DebugDumpNamespaceSimpleI{} -> wat @@ -592,7 +605,7 @@ loop = do Just ty -> do let steps = bimap (Path.unabsolute . resolveToAbsolute) - (const . step $ Type.toReference ty) + (const . step $ Hashing.typeToReference ty) <$> srcs stepManyAtNoSync steps where @@ -663,6 +676,10 @@ loop = do doDisplay outputLoc ns tm in case input of + + CreateMessage pretty -> + respond $ PrintMessage pretty + ShowReflogI -> do entries <- convertEntries Nothing [] <$> eval LoadReflog numberedArgs .= @@ -673,7 +690,7 @@ loop = do -- discontinuity in the reflog. convertEntries :: Maybe Branch.Hash -> [Output.ReflogEntry] - -> [Reflog.Entry] + -> [Reflog.Entry Branch.Hash] -> [Output.ReflogEntry] convertEntries _ acc [] = acc convertEntries Nothing acc entries@(Reflog.Entry old _ _ : _) = @@ -869,6 +886,10 @@ loop = do branch' <- getAt path when (Branch.isEmpty branch') (respond $ CreatedNewBranch path) + UpI -> use currentPath >>= \p -> case Path.unsnoc (Path.unabsolute p) of + Nothing -> pure () + Just (path,_) -> currentPathStack %= Nel.cons (Path.Absolute path) + PopBranchI -> use (currentPathStack . to Nel.uncons) >>= \case (_, Nothing) -> respond StartOfCurrentPathHistory (_, Just t) -> currentPathStack .= t @@ -907,7 +928,7 @@ loop = do diffHelper (Branch.head prev) (Branch.head root') >>= respondNumbered . uncurry Output.ShowDiffAfterUndo - UiI -> eval UI + UiI -> eval UI AliasTermI src dest -> do referents <- resolveHHQS'Referents src @@ -1416,7 +1437,7 @@ loop = do where n = Name.fromVar v hashTerms :: Map Reference (Type v Ann) hashTerms = Map.fromList (toList hashTerms0) where - hashTerms0 = (\(r, _, typ) -> (r, typ)) <$> UF.hashTerms uf + hashTerms0 = (\(r, _wk, _tm, typ) -> (r, typ)) <$> UF.hashTerms uf termEdits :: Map Name (Reference, Reference) termEdits = Map.fromList $ map g (toList $ SC.terms (updates sr)) where g v = case ( toList (Names.refTermsNamed slurpCheckNames0 n) @@ -1516,7 +1537,7 @@ loop = do | (r, Term.List' ts) <- Map.toList results , Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts , cid == DD.failConstructorId && ref == DD.testResultRef ] - cachedTests <- fmap Map.fromList . eval $ LoadWatches UF.TestWatch testRefs + cachedTests <- fmap Map.fromList . eval $ LoadWatches WK.TestWatch testRefs let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) names <- makePrintNamesFromLabeled' $ LD.referents testTerms <> @@ -1541,7 +1562,7 @@ loop = do Left e -> respond (EvaluationFailure e) $> [] Right tm' -> do -- After evaluation, cache the result of the test - eval $ PutWatch UF.TestWatch rid tm' + eval $ PutWatch WK.TestWatch rid tm' respond $ TestIncrementalOutputEnd ppe (n,total) r tm' pure [(r, tm')] r -> error $ "unpossible, tests can't be builtins: " <> show r @@ -1670,13 +1691,14 @@ loop = do makePrintNamesFromLabeled' (Patch.labeledDependencies patch) respond $ ListEdits patch ppe - PullRemoteBranchI mayRepo path syncMode -> unlessError do + PullRemoteBranchI mayRepo path syncMode verbosity -> unlessError do ns <- maybe (writePathToRead <$> resolveConfiguredGitUrl Pull path) pure mayRepo lift $ unlessGitError do b <- importRemoteBranch ns syncMode let msg = Just $ PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path - lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b (Just path) destAbs + let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path + lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b printDiffPath destAbs PushRemoteBranchI mayRepo path syncMode -> do let srcAbs = resolveToAbsolute path @@ -1737,16 +1759,13 @@ loop = do numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing) respond $ ListDependencies hqLength ld names missing DebugNumberedArgsI -> use numberedArgs >>= respond . DumpNumberedArgs - DebugBranchHistoryI -> - eval . Notify . DumpBitBooster (Branch.headHash currentBranch') =<< - (eval . Eval $ Causal.hashToRaw (Branch._history currentBranch')) DebugTypecheckedUnisonFileI -> case uf of Nothing -> respond NoUnisonFile Just uf -> let datas, effects, terms :: [(Name, Reference.Id)] datas = [ (Name.fromVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf ] effects = [ (Name.fromVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf ] - terms = [ (Name.fromVar v, r) | (v, (r, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf ] + terms = [ (Name.fromVar v, r) | (v, (r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf ] in eval . Notify $ DumpUnisonFileHashes hqLength datas effects terms DebugDumpNamespacesI -> do let seen h = State.gets (Set.member h) @@ -1915,7 +1934,7 @@ getLinks input src mdTypeStr = ExceptT $ do Right Nothing -> go Nothing Right (Just mdTypeStr) -> parseType input mdTypeStr >>= \case Left e -> pure $ Left e - Right typ -> go . Just . Set.singleton $ Type.toReference typ + Right typ -> go . Just . Set.singleton $ Hashing.typeToReference typ getLinks' :: (Var v, Monad m) => Path.HQSplit' -- definition to print metadata of @@ -2205,7 +2224,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb destb <- getAt dest merged <- eval $ Merge mode srcb destb b <- updateAtM inputDescription dest (const $ pure merged) - for_ dest0 $ \dest0 -> + for_ dest0 $ \dest0 -> diffHelper (Branch.head destb) (Branch.head merged) >>= respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) pure b @@ -2577,7 +2596,7 @@ doSlurpAdds slurp uf = Branch.stepManyAt0 (typeActions <> termActions) termActions = map doTerm . toList $ SC.terms slurp <> Slurp.constructorsFor (SC.types slurp) uf names = UF.typecheckedToNames0 uf - tests = Set.fromList $ fst <$> UF.watchesOfKind UF.TestWatch (UF.discardTypes uf) + tests = Set.fromList $ fst <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf) (isTestType, isTestValue) = isTest md v = if Set.member v tests then Metadata.singleton isTestType isTestValue @@ -2829,7 +2848,7 @@ addWatch watchName (Just uf) = do (UF.dataDeclarationsId' uf) (UF.effectDeclarationsId' uf) (UF.topLevelComponents' uf) - (UF.watchComponents uf <> [(UF.RegularWatch, [(v2, Term.var a v, ty)])])) + (UF.watchComponents uf <> [(WK.RegularWatch, [(v2, Term.var a v, ty)])])) _ -> addWatch watchName Nothing -- Given a typechecked file with a main function called `mainName` diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 7477f4985f..c808d672fb 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -9,11 +9,13 @@ module Unison.Codebase.Editor.Input import Unison.Prelude -import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' import Unison.Codebase.Path ( Path' ) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.Editor.RemoteRepo import Unison.ShortHash (ShortHash) import Unison.Codebase.ShortBranchHash (ShortBranchHash) @@ -21,6 +23,8 @@ import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Codebase.SyncMode ( SyncMode ) import Unison.Name ( Name ) import Unison.NameSegment ( NameSegment ) +import qualified Unison.Util.Pretty as P +import Unison.Codebase.Verbosity import qualified Data.Text as Text @@ -50,15 +54,18 @@ data Input | MergeLocalBranchI Path' Path' Branch.MergeMode | PreviewMergeLocalBranchI Path' Path' | DiffNamespaceI Path' Path' -- old new - | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode + | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode Verbosity | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' | ResetRootI (Either ShortBranchHash Path') -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? + -- used in Welcome module to give directions to user + | CreateMessage (P.Pretty P.ColorText) -- change directory | SwitchBranchI Path' + | UpI | PopBranchI -- > names foo -- > names foo.bar @@ -133,7 +140,6 @@ data Input | ListDependenciesI (HQ.HashQualified Name) | ListDependentsI (HQ.HashQualified Name) | DebugNumberedArgsI - | DebugBranchHistoryI | DebugTypecheckedUnisonFileI | DebugDumpNamespacesI | DebugDumpNamespaceSimpleI @@ -148,4 +154,4 @@ data OutputLocation | LatestFileLocation | FileLocation FilePath -- ClipboardLocation - deriving (Eq, Show) + deriving (Eq, Show) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index 0aef180970..1cadaaf852 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -21,12 +21,12 @@ import Unison.Server.Backend (ShallowListEntry(..)) import Unison.Codebase.Editor.Input import Unison.Codebase (GetRootBranchError) import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) -import Unison.Codebase.GitError import Unison.Codebase.Path (Path') import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Type (GitError) import Unison.Name ( Name ) import Unison.Names2 ( Names ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Reference as Reference import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) @@ -41,6 +41,7 @@ import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' import qualified Unison.Parser as Parser import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Typechecker.Context as Context import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P @@ -49,6 +50,7 @@ import qualified Unison.Codebase.Editor.TodoOutput as TO import Unison.Server.SearchResult' (SearchResult') import Unison.Term (Term) import Unison.Type (Type) +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Names3 as Names import qualified Data.Set as Set import Unison.NameSegment (NameSegment) @@ -57,6 +59,7 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.WatchKind as WK type ListDetailed = Bool type SourceName = Text @@ -90,6 +93,8 @@ data Output v = Success -- User did `add` or `update` before typechecking a file? | NoUnisonFile + -- Used in Welcome module to instruct user + | PrintMessage (P.Pretty P.ColorText) | InvalidSourceName String | SourceLoadFailed String -- No main function, the [Type v Ann] are the allowed types @@ -152,7 +157,7 @@ data Output v | Evaluated SourceFileContents PPE.PrettyPrintEnv [(v, Term v ())] - (Map v (Ann, UF.WatchKind, Term v (), Runtime.IsCacheHit)) + (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) -- "display" definitions, possibly to a FilePath on disk (e.g. editing) @@ -238,6 +243,7 @@ type SourceFileContents = Text isFailure :: Ord v => Output v -> Bool isFailure o = case o of Success{} -> False + PrintMessage{} -> False BadRootBranch{} -> True CouldntLoadBranch{} -> True NoUnisonFile{} -> True @@ -342,4 +348,3 @@ isNumberedFailure = \case ShowDiffAfterCreatePR{} -> False ShowDiffAfterCreateAuthor{} -> False - diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs index 096e45fc32..0833ecdcf9 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs @@ -16,6 +16,7 @@ import qualified Data.Set as Set import Unison.Codebase.Branch ( Branch0(..) ) import Unison.Prelude import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Command import Unison.Codebase.Editor.Output import Unison.Codebase.Patch ( Patch(..) ) @@ -25,7 +26,7 @@ import qualified Unison.DataDeclaration as Decl import qualified Unison.Name as Name import Unison.Names3 ( Names0 ) import qualified Unison.Names2 as Names -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann(..)) import Unison.Reference ( Reference(..) ) import qualified Unison.Reference as Reference import Unison.Referent ( Referent ) @@ -43,14 +44,16 @@ import qualified Unison.Codebase.Metadata as Metadata import qualified Unison.Codebase.TypeEdit as TypeEdit import Unison.Codebase.TermEdit ( TermEdit(..) ) import qualified Unison.Codebase.TermEdit as TermEdit +import qualified Unison.Codebase.TermEdit.Typing as TermEdit import Unison.Codebase.TypeEdit ( TypeEdit(..) ) import Unison.UnisonFile ( UnisonFile(..) ) import qualified Unison.UnisonFile as UF import qualified Unison.Util.Star3 as Star3 import Unison.Type ( Type ) -import qualified Unison.Type as Type import qualified Unison.Typechecker as Typechecker import qualified Unison.Runtime.IOSource as IOSource +import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.WatchKind (WatchKind) type F m i v = Free (Command m i v) @@ -321,7 +324,7 @@ propagate rootNames patch b = case validatePatch patch of declMap = over _2 (either Decl.toDataDecl id) <$> componentMap' -- TODO: kind-check the new components hashedDecls = (fmap . fmap) (over _2 DerivedId) - . Decl.hashDecls + . Hashing.hashDecls $ view _2 <$> declMap hashedComponents' <- case hashedDecls of Left _ -> @@ -390,7 +393,7 @@ propagate rootNames patch b = case validatePatch patch of let joinedStuff = toList (Map.intersectionWith f componentMap componentMap'') - f (oldRef, _oldTerm, oldType) (newRef, newTerm, newType) = + f (oldRef, _oldTerm, oldType) (newRef, _newWatchKind, newTerm, newType) = (oldRef, newRef, newTerm, oldType, newType') -- Don't replace the type if it hasn't changed. @@ -492,7 +495,7 @@ propagate rootNames patch b = case validatePatch patch of verifyTermComponent :: Map v (Reference, Term v _, a) -> Edits v - -> F m i v (Maybe (Map v (Reference, Term v _, Type v _))) + -> F m i v (Maybe (Map v (Reference, Maybe WatchKind, Term v _, Type v _))) verifyTermComponent componentMap Edits {..} = do -- If the term contains references to old patterns, we can't update it. -- If the term had a redunant type signature, it's discarded and a new type @@ -560,7 +563,7 @@ applyDeprecations patch = deleteDeprecatedTerms deprecatedTerms applyPropagate :: Var v => Applicative m => Patch -> Edits v -> F m i v (Branch0 m -> Branch0 m) applyPropagate patch Edits {..} = do - let termTypes = Map.map (Type.toReference . snd) newTerms + let termTypes = Map.map (Hashing.typeToReference . snd) newTerms -- recursively update names and delete deprecated definitions pure $ Branch.stepEverywhere (updateLevel termReplacements typeReplacements termTypes) where diff --git a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs index a65d80f183..c765f5f523 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs @@ -9,7 +9,7 @@ import Unison.Prelude import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..)) import Unison.Name ( Name ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann ( Ann ) import Unison.Var (Var) import qualified Data.Map as Map import qualified Data.Set as Set @@ -23,6 +23,7 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import qualified Unison.TypePrinter as TP import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF import qualified Unison.Util.Monoid as Monoid import qualified Unison.Util.Pretty as P import qualified Unison.Util.Relation as R @@ -232,7 +233,7 @@ pretty isPast ppe sr = okTerm v = case Map.lookup v tms of Nothing -> [(P.bold (prettyVar v), Just $ P.red "(Unison bug, unknown term)")] - Just (_, _, ty) -> + Just (_, _, _, ty) -> ( plus <> P.bold (prettyVar v) , Just $ ": " <> P.indentNAfterNewline 2 (TP.pretty ppe ty) ) @@ -279,7 +280,7 @@ pretty isPast ppe sr = <$> toList (types (defsWithBlockedDependencies sr)) ) termLineFor status v = case Map.lookup v tms of - Just (_ref, _tm, ty) -> + Just (_ref, _wk, _tm, ty) -> ( prettyStatus status , P.bold (P.text $ Var.name v) , ": " <> P.indentNAfterNewline 6 (TP.pretty ppe ty) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs b/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs index 0ac0a7d473..4f4bf48720 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs @@ -12,12 +12,12 @@ import qualified Unison.Codebase.Path as Path import Data.Void (Void) -- |"release/M1j.2" -> "releases._M1j" --- "devel/*" -> "trunk" +-- "latest-*" -> "trunk" defaultBaseLib :: Parsec Void Text ReadRemoteNamespace -defaultBaseLib = fmap makeNS $ devel <|> release +defaultBaseLib = fmap makeNS $ latest <|> release where - devel, release, version :: Parsec Void Text Text - devel = "devel/" *> many anyChar *> eof $> "trunk" + latest, release, version :: Parsec Void Text Text + latest = "latest-" *> many anyChar *> eof $> "trunk" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = fmap Text.pack $ try (someTill anyChar "." <* many anyChar) <|> many anyChar diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index b545d1063e..9003c37e17 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -15,13 +15,14 @@ import Unison.Prelude import Unison.Codebase.MainTerm ( getMainTerm ) import qualified Unison.Codebase.MainTerm as MainTerm import qualified Unison.Codebase as Codebase -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Codebase.Runtime as Runtime import Unison.Codebase.Runtime ( Runtime ) import Unison.Var ( Var ) import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Names3 as Names3 import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import System.Exit (die) import Control.Exception (finally) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs index 3e44ee25de..2981b82a5c 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs @@ -1,335 +1,22 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +module Unison.Codebase.FileCodebase (codebaseExists) where -module Unison.Codebase.FileCodebase - ( - codebase1', -- used by Test/Git - Unison.Codebase.FileCodebase.init, - openCodebase -- since init requires a bunch of irrelevant args now - ) -where - -import Control.Concurrent (forkIO, killThread) -import Control.Exception.Safe (MonadCatch, catchIO) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.IO as TextIO -import System.Directory (canonicalizePath) -import System.FilePath (dropExtension) -import Unison.Codebase (BuiltinAnnotation, Codebase (Codebase), CodebasePath) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch (Branch) -import qualified Unison.Codebase.Branch as Branch -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.Extra ((||^)) import System.FilePath (()) -import qualified U.Util.Cache as Cache -import qualified Unison.Codebase.Init as Codebase -import Unison.Codebase.Branch (headHash) -import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch, withIOError, withStatus) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), writeToRead, printWriteRepo) -import Unison.Codebase.FileCodebase.Common - ( Err (CantParseBranchHead), - branchFromFiles, - branchHashesByPrefix, - branchHeadDir, - codebaseExists, - componentIdFromString, - decodeFileName, - dependentsDir, - failWith, - formatAnn, - getDecl, - getPatch, - getRootBranch, - getTerm, - getTypeOfTerm, - getWatch, - hashExists, - hashFromFilePath, - listDirectory, - patchExists, - putBranch, - putDecl, - putRootBranch, - putTerm, - putWatch, - referentIdFromString, - reflogPath, - serializeEdits, - termReferencesByPrefix, - termReferentsByPrefix, - typeIndexDir, - typeMentionsIndexDir, - typeReferencesByPrefix, - updateCausalHead, - watchesDir, codebasePath - ) -import qualified Unison.Codebase.FileCodebase.Common as Common -import qualified Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex as Sync -import Unison.Codebase.GitError (GitError) -import qualified Unison.Codebase.GitError as GitError -import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Reflog as Reflog -import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.Codebase.Watch as Watch -import Unison.Parser (Ann ()) -import Unison.Prelude -import Unison.Reference (Reference) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import Unison.Symbol (Symbol) -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Pretty as P -import qualified Unison.Util.TQueue as TQueue -import U.Util.Timing (time) -import Unison.Var (Var) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) -import UnliftIO.STM (atomically) - -init :: (MonadIO m, MonadCatch m) => Codebase.Init m Symbol Ann -init = Codebase.Init - (const $ (fmap . fmap) (pure (),) . openCodebase) - (const $ (fmap . fmap) (pure (),) . createCodebase) - ( Common.codebasePath) - - --- get the codebase in dir -openCodebase :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m (Either Codebase.Pretty (Codebase m Symbol Ann)) -openCodebase dir = do - prettyDir <- liftIO $ P.string <$> canonicalizePath dir - let theCodebase = codebase1 @m @Symbol @Ann Cache.nullCache V1.formatSymbol formatAnn dir - ifM (codebaseExists dir) - (Right <$> theCodebase) - (pure . Left $ "No FileCodebase structure found at " <> prettyDir) +import Unison.Codebase (CodebasePath) +import Unison.Prelude (MonadIO) +import UnliftIO.Directory (doesDirectoryExist) -createCodebase :: - forall m. - (MonadIO m, MonadCatch m) => - CodebasePath -> - m (Either Codebase.CreateCodebaseError (Codebase m Symbol Ann)) -createCodebase dir = ifM - (codebaseExists dir) - (pure $ Left Codebase.CreateCodebaseAlreadyExists) - (do - codebase <- codebase1 @m @Symbol @Ann Cache.nullCache V1.formatSymbol formatAnn dir - Codebase.putRootBranch codebase Branch.empty - pure $ Right codebase) +-- checks if a minimal codebase structure exists at `path` +codebaseExists :: MonadIO m => CodebasePath -> m Bool +codebaseExists root = + and <$> traverse doesDirectoryExist (minimalCodebaseStructure root) --- builds a `Codebase IO v a`, given serializers for `v` and `a` -codebase1 - :: forall m v a - . MonadIO m - => MonadCatch m - => Var v - => BuiltinAnnotation a - => Branch.Cache m -> S.Format v -> S.Format a -> CodebasePath -> m (Codebase m v a) -codebase1 = codebase1' Sync.syncToDirectory - -codebase1' - :: forall m v a - . MonadIO m - => MonadCatch m - => Var v - => BuiltinAnnotation a - => Common.SyncToDir m v a -> Branch.Cache m -> S.Format v -> S.Format a -> CodebasePath -> m (Codebase m v a) -codebase1' syncToDirectory branchCache fmtV@(S.Format getV putV) fmtA@(S.Format getA putA) path = do - termCache <- Cache.semispaceCache 8192 - typeOfTermCache <- Cache.semispaceCache 8192 - declCache <- Cache.semispaceCache 1024 - let addDummyCleanup (a,b) = (pure (), a, b) - c = - Codebase - (Cache.applyDefined termCache $ getTerm getV getA path) - (Cache.applyDefined typeOfTermCache $ getTypeOfTerm getV getA path) - (Cache.applyDefined declCache $ getDecl getV getA path) - (putTerm putV putA path) - (putDecl putV putA path) - (getRootBranch branchCache path) - (putRootBranch path) - (branchHeadUpdates path) - (branchFromFiles branchCache path) - (putBranch path) - (hashExists path) - (getPatch path) - (\h p -> serializeEdits path h (pure p)) - (patchExists path) - dependents - (flip (syncToDirectory fmtV fmtA) path) - (syncToDirectory fmtV fmtA path) - (runExceptT . fmap addDummyCleanup . viewRemoteBranch' Cache.nullCache) - (\b r m -> runExceptT $ - pushGitRootBranch (syncToDirectory fmtV fmtA path) Cache.nullCache b r m) - watches - (getWatch getV getA path) - (putWatch putV putA path) - (removeDirectoryRecursive $ path codebasePath "watches") - getReflog - appendReflog - getTermsOfType - getTermsMentioningType - -- todo: maintain a trie of references to come up with this number - (pure 10) - -- The same trie can be used to make this lookup fast: - (termReferencesByPrefix path) - (typeReferencesByPrefix path) - (termReferentsByPrefix (getDecl getV getA) path) - (pure 10) - (branchHashesByPrefix path) - Nothing -- just use in memory Branch.lca - Nothing -- just use in memory Branch.before - in pure c where - dependents :: Reference -> m (Set Reference.Id) - dependents r = listDirAsIds (dependentsDir path r) - getTermsOfType :: Reference -> m (Set Referent.Id) - getTermsOfType r = listDirAsReferents (typeIndexDir path r) - getTermsMentioningType :: Reference -> m (Set Referent.Id) - getTermsMentioningType r = listDirAsReferents (typeMentionsIndexDir path r) - -- todo: revisit these - listDirAsIds :: FilePath -> m (Set Reference.Id) - listDirAsIds d = do - e <- doesDirectoryExist d - if e - then do - ls <- fmap decodeFileName <$> listDirectory d - pure . Set.fromList $ ls >>= (toList . componentIdFromString) - else pure Set.empty - listDirAsReferents :: FilePath -> m (Set Referent.Id) - listDirAsReferents d = do - e <- doesDirectoryExist d - if e - then do - ls <- fmap decodeFileName <$> listDirectory d - pure . Set.fromList $ ls >>= (toList . referentIdFromString) - else pure Set.empty - watches :: UF.WatchKind -> m [Reference.Id] - watches k = - liftIO $ do - let wp = watchesDir path (Text.pack k) - createDirectoryIfMissing True wp - ls <- listDirectory wp - pure $ ls >>= (toList . componentIdFromString . dropExtension) - getReflog :: m [Reflog.Entry] - getReflog = - liftIO - (do contents <- TextIO.readFile (reflogPath path) - let lines = Text.lines contents - let entries = parseEntry <$> lines - pure entries) `catchIO` const (pure []) - where - parseEntry t = fromMaybe (err t) (Reflog.fromText t) - err t = error $ - "I couldn't understand this line in " ++ reflogPath path ++ "\n\n" ++ - Text.unpack t - appendReflog :: Text -> Branch m -> Branch m -> m () - appendReflog reason old new = - let - t = Reflog.toText $ - Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason - in liftIO $ TextIO.appendFile (reflogPath path) (t <> "\n") - --- watches in `branchHeadDir root` for externally deposited heads; --- parse them, and return them -branchHeadUpdates - :: MonadIO m => CodebasePath -> m (IO (), IO (Set Branch.Hash)) -branchHeadUpdates root = do - branchHeadChanges <- TQueue.newIO - (cancelWatch, watcher) <- Watch.watchDirectory' (branchHeadDir root) --- -- add .ubf file changes to intermediate queue - watcher1 <- - liftIO . forkIO - $ forever - $ do - -- Q: what does watcher return on a file deletion? - -- A: nothing - (filePath, _) <- watcher - case hashFromFilePath filePath of - Nothing -> failWith $ CantParseBranchHead filePath - Just h -> - atomically . TQueue.enqueue branchHeadChanges $ Branch.Hash h - -- smooth out intermediate queue - pure - ( cancelWatch >> killThread watcher1 - , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 - ) + -- checks if `path` looks like a unison codebase + minimalCodebaseStructure :: CodebasePath -> [FilePath] + minimalCodebaseStructure root = [ branchHeadDir root ] --- * Git stuff + branchesDir root = root codebasePath "paths" + branchHeadDir root = branchesDir root "_head" -viewRemoteBranch' :: forall m. (MonadIO m, MonadCatch m) - => Branch.Cache m -> ReadRemoteNamespace -> ExceptT GitError m (Branch m, CodebasePath) -viewRemoteBranch' cache (repo, sbh, path) = do - -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch repo - -- try to load the requested branch from it - branch <- time "Git fetch (sbh)" $ case sbh of - -- load the root branch - Nothing -> lift (getRootBranch cache remotePath) >>= \case - Left Codebase.NoRootBranch -> pure Branch.empty - Left (Codebase.CouldntLoadRootBranch h) -> - throwError $ GitError.CouldntLoadRootBranch repo h - Left (Codebase.CouldntParseRootBranch s) -> - throwError $ GitError.CouldntParseRootBranch repo s - Right b -> pure b - -- load from a specific `ShortBranchHash` - Just sbh -> do - branchCompletions <- lift $ branchHashesByPrefix remotePath sbh - case toList branchCompletions of - [] -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh - [h] -> (lift $ branchFromFiles cache remotePath h) >>= \case - Just b -> pure b - Nothing -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh - _ -> throwError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions - pure (Branch.getAt' path branch, remotePath) - --- Given a branch that is "after" the existing root of a given git repo, --- stage and push the branch (as the new root) + dependencies to the repo. -pushGitRootBranch - :: (MonadIO m, MonadCatch m) - => Codebase.SyncToDir m - -> Branch.Cache m - -> Branch m - -> WriteRepo - -> SyncMode - -> ExceptT GitError m () -pushGitRootBranch syncToDirectory cache branch repo syncMode = do - -- Pull the remote repo into a staging directory - (remoteRoot, remotePath) <- viewRemoteBranch' cache (writeToRead repo, Nothing, Path.empty) - ifM (pure (remoteRoot == Branch.empty) - ||^ lift (remoteRoot `Branch.before` branch)) - -- ours is newer πŸ‘, meaning this is a fast-forward push, - -- so sync branch to staging area - (stageAndPush remotePath) - (throwError $ GitError.PushDestinationHasNewStuff repo) - where - stageAndPush remotePath = do - let repoString = Text.unpack $ printWriteRepo repo - withStatus ("Staging files for upload to " ++ repoString ++ " ...") $ - lift (syncToDirectory remotePath syncMode branch) - updateCausalHead (branchHeadDir remotePath) (Branch._history branch) - -- push staging area to remote - withStatus ("Uploading to " ++ repoString ++ " ...") $ - unlessM - (push remotePath repo - `withIOError` (throwError . GitError.PushException repo . show)) - (throwError $ GitError.PushNoOp repo) - -- Commit our changes - push :: CodebasePath -> WriteRepo -> IO Bool -- withIOError needs IO - push remotePath (WriteGitRepo url) = do - -- has anything changed? - status <- gitTextIn remotePath ["status", "--short"] - if Text.null status then - pure False - else do - gitIn remotePath ["add", "--all", "."] - gitIn remotePath - ["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ headHash branch)] - -- Push our changes to the repo - gitIn remotePath ["push", "--quiet", url] - pure True + codebasePath :: FilePath + codebasePath = ".unison" "v1" diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs deleted file mode 100644 index 94e837cc90..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.FileCodebase.Branch.Dependencies where - -import Data.Set (Set) -import Data.Foldable (toList) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Unison.Codebase.Branch (Branch(Branch), Branch0, EditHash) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import GHC.Generics (Generic) -import Data.Monoid.Generic -import Data.Map (Map) -import Unison.NameSegment (NameSegment) -import Unison.Referent (Referent) -import Unison.Codebase.Patch (Patch) -import qualified Unison.Util.Star3 as Star3 -import qualified Unison.Util.Relation as R -import Unison.Reference (Reference(DerivedId)) - -type Branches m = [(Branch.Hash, Maybe (m (Branch m)))] - -data Dependencies = Dependencies - { patches :: Set EditHash - , terms :: Set Reference.Id - , decls :: Set Reference.Id - } - deriving Show - deriving Generic - deriving Semigroup via GenericSemigroup Dependencies - deriving Monoid via GenericMonoid Dependencies - -data Dependencies' = Dependencies' - { patches' :: [EditHash] - , terms' :: [Reference.Id] - , decls' :: [Reference.Id] - } - deriving Show - deriving Generic - deriving Semigroup via GenericSemigroup Dependencies' - deriving Monoid via GenericMonoid Dependencies' - - -to' :: Dependencies -> Dependencies' -to' Dependencies{..} = Dependencies' (toList patches) (toList terms) (toList decls) - -fromBranch :: Applicative m => Branch m -> (Branches m, Dependencies) -fromBranch (Branch c) = case c of - Causal.One _hh e -> fromBranch0 e - Causal.Cons _hh e (h, m) -> fromBranch0 e <> fromTails (Map.singleton h m) - Causal.Merge _hh e tails -> fromBranch0 e <> fromTails tails - where - fromTails m = ([(h, Just (Branch <$> mc)) | (h, mc) <- Map.toList m], mempty) - -fromRawCausal :: Causal.Raw Branch.Raw (Branches m, Dependencies) - -> (Branches m, Dependencies) -fromRawCausal = \case - Causal.RawOne e -> e - Causal.RawCons e h -> e <> fromTails [h] - Causal.RawMerge e hs -> e <> fromTails (toList hs) - where - fromTails ts = (fmap (,Nothing) ts, mempty) - -fromBranch0 :: Applicative m => Branch0 m -> (Branches m, Dependencies) -fromBranch0 b = - ( fromChildren (Branch._children b) - , fromTermsStar (Branch._terms b) - <> fromTypesStar (Branch._types b) - <> fromEdits (Branch._edits b) ) - where - fromChildren :: Applicative m => Map NameSegment (Branch m) -> Branches m - fromChildren m = [ (Branch.headHash b, Just (pure b)) | b <- toList m ] - references :: Branch.Star r NameSegment -> [r] - references = toList . R.dom . Star3.d1 - mdValues :: Branch.Star r NameSegment -> [Reference] - mdValues = fmap snd . toList . R.ran . Star3.d3 - fromTermsStar :: Branch.Star Referent NameSegment -> Dependencies - fromTermsStar s = Dependencies mempty terms decls where - terms = Set.fromList $ - [ i | Referent.Ref (DerivedId i) <- references s] ++ - [ i | DerivedId i <- mdValues s] - decls = Set.fromList $ - [ i | Referent.Con (DerivedId i) _ _ <- references s ] - fromTypesStar :: Branch.Star Reference NameSegment -> Dependencies - fromTypesStar s = Dependencies mempty terms decls where - terms = Set.fromList [ i | DerivedId i <- mdValues s ] - decls = Set.fromList [ i | DerivedId i <- references s ] - fromEdits :: Map NameSegment (EditHash, m Patch) -> Dependencies - fromEdits m = Dependencies (Set.fromList . fmap fst $ toList m) mempty mempty diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs deleted file mode 100644 index 12238dd737..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs +++ /dev/null @@ -1,607 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Common - ( Err(..) - , SyncToDir - , SimpleLens - , codebaseExists - , codebasePath - , hashExists - -- dirs (parent of all the files) - , branchHeadDir - , dependentsDir - , dependentsDir' - , typeIndexDir - , typeIndexDir' - , typeMentionsIndexDir - , typeMentionsIndexDir' - , watchesDir - -- paths (looking up one file) - , branchPath - , declPath - , editsPath - , reflogPath - , termPath - , typePath - , watchPath - -- core stuff - , formatAnn - , getDecl - , putDecl - , putRootBranch - , getTerm - , getTypeOfTerm - , putTerm - , getWatch - , putWatch - , updateCausalHead - , serializeEdits - , deserializeEdits - , serializeRawBranch - , branchFromFiles - , putBranch - , getPatch - , patchExists - , branchHashesByPrefix - , termReferencesByPrefix - , termReferentsByPrefix - , typeReferencesByPrefix - -- stringing - , hashFromFilePath - , componentIdFromString - , componentIdToString - , referentIdFromString - -- touching files - , touchIdFile - , touchReferentFile - , touchReferentIdFile - -- util - , copyFileWithParents - , doFileOnce - , failWith - , listDirectory - -- expose for tests :| - , encodeFileName - , decodeFileName - , getRootBranch - - ) where - -import Unison.Prelude - -import Control.Error (runExceptT, ExceptT(..)) -import Control.Lens (Lens, use, to, (%=)) -import Control.Monad.Catch (catch) -import Control.Monad.State (MonadState) -import qualified Data.ByteString.Base16 as ByteString (decodeBase16, encodeBase16) -import qualified Data.Char as Char -import Data.List ( isPrefixOf ) -import qualified Data.Set as Set -import qualified Data.Text as Text -import UnliftIO.Directory ( createDirectoryIfMissing - , doesFileExist - , removeFile - , doesDirectoryExist, copyFile - ) -import UnliftIO.IO.File (writeBinaryFile) -import qualified System.Directory -import System.FilePath ( takeBaseName - , takeDirectory - , () - ) -import qualified Unison.Codebase as Codebase -import Unison.Codebase (CodebasePath) -import Unison.Codebase.Causal ( Causal - , RawHash(..) - ) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Branch ( Branch ) -import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.ShortBranchHash (ShortBranchHash(..)) -import qualified Unison.Codebase.ShortBranchHash as SBH -import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.Codebase.SyncMode ( SyncMode ) -import Unison.Codebase.Patch ( Patch(..) ) -import qualified Unison.ConstructorType as CT -import qualified Unison.DataDeclaration as DD -import qualified Unison.Hash as Hash -import Unison.Parser ( Ann(External) ) -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import Unison.Referent ( Referent ) -import qualified Unison.Referent as Referent -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import Unison.Term ( Term ) -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import Unison.Var ( Var ) -import qualified Unison.UnisonFile as UF -import Unison.Util.Monoid (foldMapM) -import U.Util.Timing (time) -import Data.Either.Extra (maybeToEither) - -data Err - = InvalidBranchFile FilePath String - | InvalidEditsFile FilePath String - | NoBranchHead FilePath - | CantParseBranchHead FilePath - | AmbiguouslyTypeAndTerm Reference.Id - | UnknownTypeOrTerm Reference - deriving Show - -type SimpleLens s a = Lens s s a a - -codebasePath :: FilePath -codebasePath = ".unison" "v1" - -formatAnn :: S.Format Ann -formatAnn = S.Format (pure External) (\_ -> pure ()) - --- Write Branch and its dependents to the dest codebase -type SyncToDir m v a - = S.Format v - -> S.Format a - -> CodebasePath -- src codebase - -> CodebasePath -- dest codebase - -> SyncMode - -> Branch m -- branch to sync to dest codebase - -> m () - -termsDir, typesDir, branchesDir, branchHeadDir, editsDir - :: CodebasePath -> FilePath -termsDir root = root codebasePath "terms" -typesDir root = root codebasePath "types" -branchesDir root = root codebasePath "paths" -branchHeadDir root = branchesDir root "_head" -editsDir root = root codebasePath "patches" - -termDir, declDir :: CodebasePath -> Reference.Id -> FilePath -termDir root r = termsDir root componentIdToString r -declDir root r = typesDir root componentIdToString r - -referenceToDir :: Reference -> FilePath -referenceToDir r = case r of - Reference.Builtin name -> "_builtin" encodeFileName (Text.unpack name) - Reference.DerivedId hash -> componentIdToString hash - -dependentsDir', typeIndexDir', typeMentionsIndexDir' :: FilePath -> FilePath - -dependentsDir :: CodebasePath -> Reference -> FilePath -dependentsDir root r = dependentsDir' root referenceToDir r -dependentsDir' root = root codebasePath "dependents" - -watchesDir :: CodebasePath -> Text -> FilePath -watchesDir root UF.RegularWatch = - root codebasePath "watches" "_cache" -watchesDir root kind = - root codebasePath "watches" encodeFileName (Text.unpack kind) -watchPath :: CodebasePath -> UF.WatchKind -> Reference.Id -> FilePath -watchPath root kind id = - watchesDir root (Text.pack kind) componentIdToString id <> ".ub" - -typeIndexDir :: CodebasePath -> Reference -> FilePath -typeIndexDir root r = typeIndexDir' root referenceToDir r -typeIndexDir' root = root codebasePath "type-index" - -typeMentionsIndexDir :: CodebasePath -> Reference -> FilePath -typeMentionsIndexDir root r = typeMentionsIndexDir' root referenceToDir r -typeMentionsIndexDir' root = root codebasePath "type-mentions-index" - -decodeFileName :: FilePath -> String -decodeFileName = let - go ('$':tl) = case span (/= '$') tl of - ("forward-slash", _:tl) -> '/' : go tl - ("back-slash", _:tl) -> '\\' : go tl - ("colon", _:tl) -> ':' : go tl - ("star", _:tl) -> '*' : go tl - ("question-mark", _:tl) -> '?' : go tl - ("double-quote", _:tl) -> '\"' : go tl - ("less-than", _:tl) -> '<' : go tl - ("greater-than", _:tl) -> '>' : go tl - ("pipe", _:tl) -> '|' : go tl - ('x':hex, _:tl) -> decodeHex hex ++ go tl - ("",_:tl) -> '$' : go tl - (s,_:tl) -> '$' : s ++ '$' : go tl -- unknown escapes left unchanged - (s,[]) -> s - go (hd:tl) = hd : go tl - go [] = [] - decodeHex :: String -> String - decodeHex s = either (const s) (Text.unpack . decodeUtf8) - . ByteString.decodeBase16 . encodeUtf8 . Text.pack $ s - in \case - "$dot$" -> "." - "$dotdot$" -> ".." - t -> go t - --- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os -encodeFileName :: String -> FilePath -encodeFileName = let - go ('/' : rem) = "$forward-slash$" <> go rem - go ('\\' : rem) = "$back-slash$" <> go rem - go (':' : rem) = "$colon$" <> go rem - go ('*' : rem) = "$star$" <> go rem - go ('?' : rem) = "$question-mark$" <> go rem - go ('"' : rem) = "$double-quote$" <> go rem - go ('<' : rem) = "$less-than$" <> go rem - go ('>' : rem) = "$greater-than$" <> go rem - go ('|' : rem) = "$pipe$" <> go rem - go ('$' : rem) = "$$" <> go rem - go (c : rem) | not (Char.isPrint c && Char.isAscii c) - = "$x" <> encodeHex [c] <> "$" <> go rem - | otherwise = c : go rem - go [] = [] - encodeHex :: String -> String - encodeHex = Text.unpack . Text.toUpper . ByteString.encodeBase16 . - encodeUtf8 . Text.pack - in \case - "." -> "$dot$" - ".." -> "$dotdot$" - t -> go t - -termPath, typePath, declPath :: CodebasePath -> Reference.Id -> FilePath -termPath path r = termDir path r "compiled.ub" -typePath path r = termDir path r "type.ub" -declPath path r = declDir path r "compiled.ub" - -branchPath :: CodebasePath -> Branch.Hash -> FilePath -branchPath root (RawHash h) = branchesDir root hashToString h ++ ".ub" - -editsPath :: CodebasePath -> Branch.EditHash -> FilePath -editsPath root h = editsDir root hashToString h ++ ".up" - -reflogPath :: CodebasePath -> FilePath -reflogPath root = root codebasePath "reflog" - -touchIdFile :: MonadIO m => Reference.Id -> FilePath -> m () -touchIdFile id fp = - touchFile (fp encodeFileName (componentIdToString id)) - -touchReferentFile :: MonadIO m => Referent -> FilePath -> m () -touchReferentFile id fp = - touchFile (fp encodeFileName (referentToString id)) - -touchReferentIdFile :: MonadIO m => Referent.Id -> FilePath -> m () -touchReferentIdFile = touchReferentFile . Referent.fromId - -touchFile :: MonadIO m => FilePath -> m () -touchFile fp = do - createDirectoryIfMissing True (takeDirectory fp) - writeBinaryFile fp mempty - --- checks if `path` looks like a unison codebase -minimalCodebaseStructure :: CodebasePath -> [FilePath] -minimalCodebaseStructure root = [ branchHeadDir root ] - --- checks if a minimal codebase structure exists at `path` -codebaseExists :: MonadIO m => CodebasePath -> m Bool -codebaseExists root = - and <$> traverse doesDirectoryExist (minimalCodebaseStructure root) - --- | load a branch w/ children from a FileCodebase -branchFromFiles :: MonadIO m => Branch.Cache m -> CodebasePath -> Branch.Hash -> m (Maybe (Branch m)) -branchFromFiles cache rootDir h = time "FileCodebase.Common.branchFromFiles" $ do - fileExists <- doesFileExist (branchPath rootDir h) - if fileExists then Just <$> - Branch.cachedRead - cache - (deserializeRawBranch rootDir) - (deserializeEdits rootDir) - h - else - pure Nothing - where - deserializeRawBranch - :: MonadIO m => CodebasePath -> Causal.Deserialize m Branch.Raw Branch.Raw - deserializeRawBranch root h = do - let ubf = branchPath root h - S.getFromFile' (V1.getCausal0 V1.getRawBranch) ubf >>= \case - Left err -> failWith $ InvalidBranchFile ubf err - Right c0 -> pure c0 - -deserializeEdits :: MonadIO m => CodebasePath -> Branch.EditHash -> m Patch -deserializeEdits root h = - let file = editsPath root h - in S.getFromFile' V1.getEdits file >>= \case - Left err -> failWith $ InvalidEditsFile file err - Right edits -> pure edits - -getPatch :: MonadIO m => CodebasePath -> Branch.EditHash -> m (Maybe Patch) -getPatch root h = - let file = editsPath root h - in S.getFromFile' V1.getEdits file >>= \case - Left _err -> pure Nothing - Right edits -> pure (Just edits) - -getRootBranch :: forall m. - MonadIO m => Branch.Cache m -> CodebasePath -> m (Either Codebase.GetRootBranchError (Branch m)) -getRootBranch cache root = time "FileCodebase.Common.getRootBranch" $ - ifM (codebaseExists root) - (listDirectory (branchHeadDir root) >>= filesToBranch) - (pure $ Left Codebase.NoRootBranch) - where - filesToBranch :: [FilePath] -> m (Either Codebase.GetRootBranchError (Branch m)) - filesToBranch = \case - [] -> pure $ Left Codebase.NoRootBranch - [single] -> runExceptT $ fileToBranch single - conflict -> runExceptT (traverse fileToBranch conflict) >>= \case - Right (x : xs) -> Right <$> foldM Branch.merge x xs - Right _ -> error "FileCodebase.getRootBranch.conflict can't be empty." - Left e -> Left <$> pure e - - fileToBranch :: String -> ExceptT Codebase.GetRootBranchError m (Branch m) - fileToBranch single = ExceptT $ case hashFromString single of - Nothing -> pure . Left $ Codebase.CouldntParseRootBranch single - Just (Branch.Hash -> h) -> branchFromFiles cache root h <&> - maybeToEither (Codebase.CouldntLoadRootBranch h) - -putRootBranch :: MonadIO m => CodebasePath -> Branch m -> m () -putRootBranch root b = do - putBranch root b - updateCausalHead (branchHeadDir root) (Branch._history b) - --- |only syncs branches and edits -- no dependencies -putBranch :: MonadIO m => CodebasePath -> Branch m -> m () -putBranch root b = - Branch.sync (hashExists root) - (serializeRawBranch root) - (serializeEdits root) - b - -hashExists :: MonadIO m => CodebasePath -> Branch.Hash -> m Bool -hashExists root h = doesFileExist (branchPath root h) - -serializeRawBranch - :: (MonadIO m) => CodebasePath -> Causal.Serialize m Branch.Raw Branch.Raw -serializeRawBranch root h = - S.putWithParentDirs (V1.putRawCausal V1.putRawBranch) (branchPath root h) - -patchExists :: MonadIO m => CodebasePath -> Branch.EditHash -> m Bool -patchExists root h = doesFileExist (editsPath root h) - -serializeEdits - :: MonadIO m => CodebasePath -> Branch.EditHash -> m Patch -> m () -serializeEdits root h medits = - unlessM (patchExists root h) $ do - edits <- medits - S.putWithParentDirs V1.putEdits (editsPath root h) edits - --- `headDir` is like ".unison/branches/head", or ".unison/edits/head"; --- not ".unison"; a little weird. I guess the reason this doesn't take --- the codebase root path is because it's applicable to any causal. --- We just have one though, and I suppose that won't change any time soon. -updateCausalHead :: MonadIO m => FilePath -> Causal n h e -> m () -updateCausalHead headDir c = do - let (RawHash h) = Causal.currentHash c - hs = hashToString h - -- write new head - touchFile (headDir hs) - -- delete existing heads - fmap (filter (/= hs)) (listDirectory headDir) - >>= traverse_ (removeFile . (headDir )) - --- here -hashFromString :: String -> Maybe Hash.Hash -hashFromString = Hash.fromBase32Hex . Text.pack - --- here -hashToString :: Hash.Hash -> String -hashToString = Hash.base32Hexs - -hashFromFilePath :: FilePath -> Maybe Hash.Hash -hashFromFilePath = hashFromString . takeBaseName - --- here -componentIdToString :: Reference.Id -> String -componentIdToString = Text.unpack . Reference.toText . Reference.DerivedId - --- here -componentIdFromString :: String -> Maybe Reference.Id -componentIdFromString = Reference.idFromText . Text.pack - --- here -referentFromString :: String -> Maybe Referent -referentFromString = Referent.fromText . Text.pack - -referentIdFromString :: String -> Maybe Referent.Id -referentIdFromString s = referentFromString s >>= \case - Referent.Ref (Reference.DerivedId r) -> Just $ Referent.Ref' r - Referent.Con (Reference.DerivedId r) i t -> Just $ Referent.Con' r i t - _ -> Nothing - --- here -referentToString :: Referent -> String -referentToString = Text.unpack . Referent.toText - -copyFileWithParents :: MonadIO m => FilePath -> FilePath -> m () -copyFileWithParents src dest = - unlessM (doesFileExist dest) $ do - createDirectoryIfMissing True (takeDirectory dest) - copyFile src dest - --- Use State and Lens to do some specified thing at most once, to create a file. -doFileOnce :: forall m s h. (MonadIO m, MonadState s m, Ord h) - => CodebasePath - -> SimpleLens s (Set h) -- lens to track if `h` is already done - -> (CodebasePath -> h -> FilePath) -- done if this filepath exists - -> (h -> m ()) -- do! - -> h -> m () -doFileOnce destPath l getFilename f h = - unlessM (use (l . to (Set.member h))) $ do - l %= Set.insert h - unlessM (doesFileExist (getFilename destPath h)) (f h) - -getTerm :: (MonadIO m, Ord v) => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (Term v a)) -getTerm getV getA path h = S.getFromFile (V1.getTerm getV getA) (termPath path h) - -getTypeOfTerm :: (MonadIO m, Ord v) => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (Type v a)) -getTypeOfTerm getV getA path h = S.getFromFile (V1.getType getV getA) (typePath path h) - -putTerm - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> Reference.Id - -> Term v a - -> Type v a - -> m () -putTerm putV putA path h e typ = do - let typeForIndexing = Type.removeAllEffectVars typ - rootTypeHash = Type.toReference typeForIndexing - typeMentions = Type.toReferenceMentions typeForIndexing - S.putWithParentDirs (V1.putTerm putV putA) (termPath path h) e - S.putWithParentDirs (V1.putType putV putA) (typePath path h) typ - -- Add the term as a dependent of its dependencies - let r = Referent.Ref (Reference.DerivedId h) - let deps = deleteComponent h $ Term.dependencies e <> Type.dependencies typ - traverse_ (touchIdFile h . dependentsDir path) deps - traverse_ (touchReferentFile r . typeMentionsIndexDir path) typeMentions - touchReferentFile r (typeIndexDir path rootTypeHash) - -getDecl :: (MonadIO m, Ord v) - => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (DD.Decl v a)) -getDecl getV getA root h = - S.getFromFile - (V1.getEither - (V1.getEffectDeclaration getV getA) - (V1.getDataDeclaration getV getA)) - (declPath root h) - -putDecl - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> Reference.Id - -> DD.Decl v a - -> m () -putDecl putV putA path h decl = do - S.putWithParentDirs - (V1.putEither - (V1.putEffectDeclaration putV putA) - (V1.putDataDeclaration putV putA)) - (declPath path h) - decl - traverse_ (touchIdFile h . dependentsDir path) deps - traverse_ addCtorToTypeIndex ctors - where - deps = deleteComponent h . DD.dependencies $ either DD.toDataDecl id decl - r = Reference.DerivedId h - decl' = either DD.toDataDecl id decl - addCtorToTypeIndex (r, typ) = do - let rootHash = Type.toReference typ - typeMentions = Type.toReferenceMentions typ - touchReferentFile r (typeIndexDir path rootHash) - traverse_ (touchReferentFile r . typeMentionsIndexDir path) typeMentions - ct = DD.constructorType decl - ctors = - [ (Referent.Con r i ct, Type.removeAllEffectVars t) - | (t,i) <- DD.constructorTypes decl' `zip` [0..] ] - -getWatch :: (MonadIO m, Ord v) - => S.Get v - -> S.Get a - -> CodebasePath - -> UF.WatchKind - -> Reference.Id - -> m (Maybe (Term v a)) -getWatch getV getA path k id = do - let wp = watchesDir path (Text.pack k) - createDirectoryIfMissing True wp - S.getFromFile (V1.getTerm getV getA) (wp componentIdToString id <> ".ub") - -putWatch - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> UF.WatchKind - -> Reference.Id - -> Term v a - -> m () -putWatch putV putA root k id e = - S.putWithParentDirs - (V1.putTerm putV putA) - (watchPath root k id) - e - -loadReferencesByPrefix - :: MonadIO m => FilePath -> ShortHash -> m (Set Reference.Id) -loadReferencesByPrefix dir sh = do - refs <- mapMaybe Reference.fromShortHash - . filter (SH.isPrefixOf sh) - . mapMaybe SH.fromString - <$> listDirectory dir - pure $ Set.fromList [ i | Reference.DerivedId i <- refs] - -termReferencesByPrefix, typeReferencesByPrefix - :: MonadIO m => CodebasePath -> ShortHash -> m (Set Reference.Id) -termReferencesByPrefix root = loadReferencesByPrefix (termsDir root) -typeReferencesByPrefix root = loadReferencesByPrefix (typesDir root) - --- returns all the derived terms and derived constructors --- that have `sh` as a prefix -termReferentsByPrefix :: MonadIO m - => (CodebasePath -> Reference.Id -> m (Maybe (DD.Decl v a))) - -> CodebasePath - -> ShortHash - -> m (Set Referent.Id) -termReferentsByPrefix _ root sh@SH.Builtin{} = - Set.map Referent.Ref' <$> termReferencesByPrefix root sh - -- builtin types don't provide any referents we could match against, - -- only decl types do. Those get handled in the next case. -termReferentsByPrefix getDecl root sh@SH.ShortHash{} = do - terms <- termReferencesByPrefix root sh - ctors <- do - -- clear out any CID from the SH, so we can use it to find a type decl - types <- typeReferencesByPrefix root sh { SH.cid = Nothing } - foldMapM collectCtors types - pure (Set.map Referent.Ref' terms <> ctors) - where - -- load up the Decl for `ref` to see how many constructors it has, - -- and what constructor type - collectCtors ref = getDecl root ref <&> \case - Nothing -> mempty - Just decl -> - Set.fromList [ con - | i <- [0 .. ctorCount-1] - , let con = Referent.Con' ref i ct - , SH.isPrefixOf sh $ Referent.toShortHashId con] - where ct = either (const CT.Effect) (const CT.Data) decl - ctorCount = length . DD.constructors' $ DD.asDataDecl decl - -branchHashesByPrefix :: MonadIO m => CodebasePath -> ShortBranchHash -> m (Set Branch.Hash) -branchHashesByPrefix codebasePath p = - fmap (Set.fromList . join) . for [branchesDir] $ \f -> do - let dir = f codebasePath - paths <- filter (isPrefixOf . Text.unpack . SBH.toText $ p) <$> listDirectory dir - let refs = paths >>= (toList . filenameToHash) - pure refs - where - filenameToHash :: String -> Maybe Branch.Hash - filenameToHash f = case Text.splitOn "." $ Text.pack f of - [h, "ub"] -> Causal.RawHash <$> Hash.fromBase32Hex h - _ -> Nothing - -failWith :: MonadIO m => Err -> m a -failWith = liftIO . fail . show - --- | A version of listDirectory that returns mempty if the directory doesn't exist -listDirectory :: MonadIO m => FilePath -> m [FilePath] -listDirectory dir = liftIO $ - System.Directory.listDirectory dir `catch` (\(_ :: IOException) -> pure mempty) - --- | delete all the elements of a given reference component from a set -deleteComponent :: Reference.Id -> Set Reference -> Set Reference -deleteComponent r rs = Set.difference rs - (Reference.members . Reference.componentFor . Reference.DerivedId $ r) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs deleted file mode 100644 index e26ecbe719..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} - - -module Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex (syncToDirectory) where - -import Unison.Prelude - -import qualified Data.Set as Set -import Control.Lens -import Control.Monad.State.Strict ( MonadState, evalStateT ) -import Control.Monad.Writer.Strict ( MonadWriter, execWriterT ) -import qualified Control.Monad.Writer.Strict as Writer -import UnliftIO.Directory ( doesFileExist ) -import Unison.Codebase ( CodebasePath ) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Branch ( Branch(..) ) -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import qualified Unison.Codebase.Patch as Patch -import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.Codebase.SyncMode ( SyncMode ) -import qualified Unison.Codebase.SyncMode as SyncMode -import qualified Unison.Codebase.TermEdit as TermEdit -import qualified Unison.Codebase.TypeEdit as TypeEdit -import qualified Unison.DataDeclaration as DD -import qualified Unison.LabeledDependency as LD -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import Unison.Var ( Var ) -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Relation as Relation -import Unison.Util.Relation ( Relation ) -import Unison.Util.Monoid (foldMapM) -import U.Util.Timing (time) - -import Data.Monoid.Generic -import Unison.Codebase.FileCodebase.Common - -data SyncedEntities = SyncedEntities - { _syncedTerms :: Set Reference.Id - , _syncedDecls :: Set Reference.Id - , _syncedEdits :: Set Branch.EditHash - , _syncedBranches :: Set Branch.Hash - , _dependentsIndex :: Relation Reference Reference.Id - , _typeIndex :: Relation Reference Referent.Id - , _typeMentionsIndex :: Relation Reference Referent.Id - } deriving Generic - deriving Show - deriving Semigroup via GenericSemigroup SyncedEntities - deriving Monoid via GenericMonoid SyncedEntities - -makeLenses ''SyncedEntities - -syncToDirectory :: forall m v a - . MonadIO m - => Var v - => S.Format v - -> S.Format a - -> CodebasePath - -> CodebasePath - -> SyncMode - -> Branch m - -> m () -syncToDirectory fmtV fmtA = syncToDirectory' (S.get fmtV) (S.get fmtA) - -data Error - = MissingBranch Branch.Hash - | MissingPatch Branch.EditHash - | MissingTerm Reference.Id - | MissingTypeOfTerm Reference.Id - | MissingDecl Reference.Id - | InvalidBranch Branch.Hash - | InvalidTerm Reference.Id - | InvalidTypeOfTerm Reference.Id - | InvalidDecl Reference.Id - deriving (Eq, Ord, Show) - -syncToDirectory' :: forall m v a - . MonadIO m - => Var v - => S.Get v - -> S.Get a - -> CodebasePath - -> CodebasePath - -> SyncMode - -> Branch m - -> m () -syncToDirectory' getV getA srcPath destPath mode newRoot = - let warnMissingEntities = False in - flip evalStateT mempty $ do -- MonadState s m - (deps, errors) <- time "Sync Branches" $ execWriterT $ - processBranches [(Branch.headHash newRoot - ,Just . pure . Branch.transform (lift . lift) $ newRoot)] - errors' <- time "Sync Definitions" $ - execWriterT $ processDependencies (BD.to' deps) - time "Write indices" $ do - lift . writeDependentsIndex =<< use dependentsIndex - lift . writeTypeIndex =<< use typeIndex - lift . writeTypeMentionsIndex =<< use typeMentionsIndex - when (warnMissingEntities) $ for_ (errors <> errors') traceShowM - where - writeDependentsIndex :: MonadIO m => Relation Reference Reference.Id -> m () - writeDependentsIndex = writeIndexHelper (\k v -> touchIdFile v (dependentsDir destPath k)) - writeTypeIndex, writeTypeMentionsIndex :: MonadIO m => Relation Reference Referent.Id -> m () - writeTypeIndex = - writeIndexHelper (\k v -> touchReferentIdFile v (typeIndexDir destPath k)) - writeTypeMentionsIndex = - writeIndexHelper (\k v -> touchReferentIdFile v (typeMentionsIndexDir destPath k)) - writeIndexHelper - :: forall m a b. MonadIO m => (a -> b -> m ()) -> Relation a b -> m () - writeIndexHelper touchIndexFile index = - traverse_ (uncurry touchIndexFile) (Relation.toList index) - processBranches :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (BD.Dependencies, Set Error) m - => [(Branch.Hash, Maybe (m (Branch m)))] - -> m () - processBranches [] = pure () - -- for each branch, - processBranches ((h, mmb) : rest) = - let tellError = Writer.tell . (mempty,) . Set.singleton - tellDependencies = Writer.tell . (,mempty) in - -- if hash exists at the destination, skip it, mark it done - ifNeedsSyncing h destPath branchPath syncedBranches - (\h -> - -- else if hash exists at the source, enqueue its dependencies, copy it, mark it done - ifM (doesFileExist (branchPath srcPath h)) - (do - (branches, deps) <- BD.fromRawCausal <$> - (deserializeRawBranchDependencies tellError srcPath h) - copyFileWithParents (branchPath srcPath h) (branchPath destPath h) - tellDependencies deps - processBranches (branches ++ rest)) - -- else if it's in memory, enqueue its dependencies, write it, mark it done - case mmb of - Just mb -> do - b <- mb - let (branches, deps) = BD.fromBranch b - let causalRaw = Branch.toCausalRaw b - serializeRawBranch destPath h causalRaw - tellDependencies deps - processBranches (branches ++ rest) - -- else -- error? - Nothing -> do - tellError (MissingBranch h) - processBranches rest - ) - (processBranches rest) - processDependencies :: forall n - . MonadIO n - => MonadState SyncedEntities n - => MonadWriter (Set Error) n - => BD.Dependencies' - -> n () - processDependencies = \case - -- for each patch - -- enqueue its target term and type references - BD.Dependencies' (editHash : editHashes) terms decls -> - -- This code assumes that patches are always available on disk, - -- not ever just held in memory with `pure`. If that's not the case, - -- then we can do something similar to what we did with branches. - ifNeedsSyncing editHash destPath editsPath syncedEdits - (\h -> do - patch <- deserializeEdits srcPath h - -- I'm calling all the replacement terms dependents of the patches. - -- If we're supposed to replace X with Y, we don't necessarily need X, - -- but we do need Y. - let newTerms, newDecls :: [Reference.Id] - newTerms = [ i | TermEdit.Replace (Reference.DerivedId i) _ <- - toList . Relation.ran $ Patch._termEdits patch] - newDecls = [ i | TypeEdit.Replace (Reference.DerivedId i) <- - toList . Relation.ran $ Patch._typeEdits patch] - ifM (doesFileExist (editsPath srcPath h)) - (do - copyFileWithParents (editsPath srcPath h) (editsPath destPath h) - processDependencies $ - BD.Dependencies' editHashes (newTerms ++ terms) (newDecls ++ decls)) - (do - tellError (MissingPatch h) - (processDependencies $ BD.Dependencies' editHashes terms decls))) - (processDependencies $ BD.Dependencies' editHashes terms decls) - - -- for each term id - BD.Dependencies' [] (termHash : termHashes) decls -> - -- if it exists at the destination, skip it, mark it done - ifNeedsSyncing termHash destPath termPath syncedTerms - (\h -> do - -- else if it exists at the source, - ifM (doesFileExist (termPath srcPath h)) - (do - -- copy it, - -- load it, - -- enqueue its dependencies for syncing - -- enqueue its type's type dependencies for syncing - -- enqueue its type's dependencies, type & type mentions into respective indices - -- and continue - (newTerms, newDecls) <- enqueueTermDependencies h - processDependencies $ - BD.Dependencies' [] (newTerms ++ termHashes) (newDecls ++ decls) - ) - -- else -- an error? - (do - tellError (MissingTerm h) - (processDependencies $ BD.Dependencies' [] termHashes decls))) - (processDependencies $ BD.Dependencies' [] termHashes decls) - -- for each decl id - BD.Dependencies' [] [] (declHash : declHashes) -> - -- if it exists at the destination, skip it, mark it done - ifNeedsSyncing declHash destPath declPath syncedDecls - (\h -> do - -- else if it exists at the source, - ifM (doesFileExist (declPath srcPath h)) - -- copy it, - -- load it, - -- enqueue its type dependencies for syncing - -- for each constructor, - -- enqueue its dependencies, type, type mentions into respective indices - (do - newDecls <- copyAndIndexDecls h - processDependencies $ BD.Dependencies' [] [] (newDecls ++ declHashes)) - (do - tellError (MissingDecl h) - (processDependencies $ BD.Dependencies' [] [] declHashes))) - (processDependencies $ BD.Dependencies' [] [] declHashes) - BD.Dependencies' [] [] [] -> pure () - copyAndIndexDecls :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (Set Error) m - => Reference.Id - -> m [Reference.Id] - copyAndIndexDecls h = (getDecl getV getA srcPath h :: m (Maybe (DD.Decl v a))) >>= \case - Just decl -> do - copyFileWithParents (declPath srcPath h) (declPath destPath h) - let referentTypes :: [(Referent.Id, Type v a)] - referentTypes = DD.declConstructorReferents h decl - `zip` (DD.constructorTypes . DD.asDataDecl) decl - flip foldMapM referentTypes \(r, typ) -> do - let dependencies = toList (Type.dependencies typ) - dependentsIndex <>= Relation.fromManyDom dependencies h - let typeForIndexing = Type.removeAllEffectVars typ - let typeReference = Type.toReference typeForIndexing - let typeMentions = Type.toReferenceMentions typeForIndexing - typeIndex <>= Relation.singleton typeReference r - typeMentionsIndex <>= Relation.fromManyDom typeMentions r - pure [ i | Reference.DerivedId i <- dependencies ] - Nothing -> tellError (InvalidDecl h) $> mempty - - enqueueTermDependencies :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (Set Error) m - => Reference.Id - -> m ([Reference.Id], [Reference.Id]) - enqueueTermDependencies h = getTerm getV getA srcPath h >>= \case - Just term -> do - let (typeDeps, termDeps) = partitionEithers . fmap LD.toReference . toList - $ Term.labeledDependencies term - ifM (doesFileExist (typePath srcPath h)) - (getTypeOfTerm getV getA srcPath h >>= \case - Just typ -> do - copyFileWithParents (termPath srcPath h) (termPath destPath h) - copyFileWithParents (typePath srcPath h) (typePath destPath h) - whenM (doesFileExist $ watchPath srcPath UF.TestWatch h) $ - copyFileWithParents (watchPath srcPath UF.TestWatch h) - (watchPath destPath UF.TestWatch h) - let typeDeps' = toList (Type.dependencies typ) - let typeForIndexing = Type.removeAllEffectVars typ - let typeReference = Type.toReference typeForIndexing - let typeMentions = Type.toReferenceMentions typeForIndexing - dependentsIndex <>= - Relation.fromManyDom (typeDeps ++ typeDeps' ++ termDeps) h - typeIndex <>= - Relation.singleton typeReference (Referent.Ref' h) - typeMentionsIndex <>= - Relation.fromManyDom typeMentions (Referent.Ref' h) - let newDecls = [ i | Reference.DerivedId i <- typeDeps ++ typeDeps'] - let newTerms = [ i | Reference.DerivedId i <- termDeps ] - pure (newTerms, newDecls) - Nothing -> tellError (InvalidTypeOfTerm h) $> mempty) - (tellError (MissingTypeOfTerm h) $> mempty) - Nothing -> tellError (InvalidTerm h) $> mempty - - deserializeRawBranchDependencies :: forall m - . MonadIO m - => (Error -> m ()) - -> CodebasePath - -> Causal.Deserialize m Branch.Raw (BD.Branches m, BD.Dependencies) - deserializeRawBranchDependencies tellError root h = - S.getFromFile (V1.getCausal0 V1.getBranchDependencies) (branchPath root h) >>= \case - Nothing -> tellError (InvalidBranch h) $> Causal.RawOne mempty - Just results -> pure results - tellError :: forall m a. MonadWriter (Set a) m => a -> m () - tellError = Writer.tell . Set.singleton - - -- Use State and Lens to do some specified thing at most once, to create a file. - ifNeedsSyncing :: forall m s h. (MonadIO m, MonadState s m, Ord h) - => h - -> CodebasePath - -> (CodebasePath -> h -> FilePath) -- done if this filepath exists - -> SimpleLens s (Set h) -- lens to track if `h` is already done - -> (h -> m ()) -- do! - -> m () -- don't - -> m () - ifNeedsSyncing h destPath getFilename l doSync dontSync = - ifM (use (l . to (Set.member h))) dontSync $ do - l %= Set.insert h - if mode == SyncMode.Complete then doSync h - else ifM (doesFileExist (getFilename destPath h)) dontSync (doSync h) diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index dee76d036d..ceed3666c6 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -3,26 +3,25 @@ module Unison.Codebase.GitError where import Unison.Prelude import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo) -import U.Codebase.Sqlite.DbId (SchemaVersion) +import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo, ReadRemoteNamespace) type CodebasePath = FilePath -data GitError = NoGit - | UnrecognizableCacheDir Text CodebasePath - | UnrecognizableCheckoutDir Text CodebasePath - | CloneException ReadRepo String - | PushException WriteRepo String - | PushNoOp WriteRepo - -- url commit Diff of what would change on merge with remote - | PushDestinationHasNewStuff WriteRepo - | NoRemoteNamespaceWithHash ReadRepo ShortBranchHash - | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set Branch.Hash) - | CouldntLoadRootBranch ReadRepo Branch.Hash - | CouldntParseRootBranch ReadRepo String - | CouldntOpenCodebase ReadRepo CodebasePath - | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion - | SomeOtherError String - | CouldntLoadSyncedBranch Branch.Hash - deriving Show +data GitProtocolError + = NoGit + | UnrecognizableCacheDir ReadRepo CodebasePath + | UnrecognizableCheckoutDir ReadRepo CodebasePath + | CloneException ReadRepo String + | PushException WriteRepo String + | PushNoOp WriteRepo + -- url commit Diff of what would change on merge with remote + | PushDestinationHasNewStuff WriteRepo + | CleanupError SomeException + deriving Show + +data GitCodebaseError h + = NoRemoteNamespaceWithHash ReadRepo ShortBranchHash + | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set h) + | CouldntLoadRootBranch ReadRepo h + | CouldntLoadSyncedBranch ReadRemoteNamespace h + deriving Show diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 85a85e4e90..8530f02396 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -1,23 +1,47 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Init where +module Unison.Codebase.Init + ( Init (..), + DebugName, + InitError (..), + CodebaseInitOptions (..), + InitResult (..), + SpecifiedCodebase (..), + Pretty, + createCodebase, + initCodebaseAndExit, + openOrCreateCodebase, + openNewUcmCodebaseOrExit, + ) +where import System.Exit (exitFailure) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase -import Unison.Parser (Ann) +import qualified Unison.Codebase.FileCodebase as FCC +import Unison.Parser.Ann (Ann(..)) import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import UnliftIO.Directory (canonicalizePath) +import Unison.Codebase.Init.CreateCodebaseError -type Pretty = P.Pretty P.ColorText +-- CodebaseInitOptions is used to help pass around a Home directory that isn't the +-- actual home directory of the user. Useful in tests. +data CodebaseInitOptions + = Home CodebasePath + | Specified SpecifiedCodebase -data CreateCodebaseError - = CreateCodebaseAlreadyExists - | CreateCodebaseOther Pretty +data SpecifiedCodebase + = CreateWhenMissing CodebasePath + | DontCreateWhenMissing CodebasePath + +initOptionsToDir :: CodebaseInitOptions -> CodebasePath +initOptionsToDir (Home dir ) = dir +initOptionsToDir (Specified (CreateWhenMissing dir)) = dir +initOptionsToDir (Specified (DontCreateWhenMissing dir)) = dir type DebugName = String @@ -31,10 +55,59 @@ data Init m v a = Init codebasePath :: CodebasePath -> CodebasePath } +type FinalizerAndCodebase m v a = (m (), Codebase m v a) + +data InitError + = NoCodebaseFoundAtSpecifiedDir + | FoundV1Codebase + | CouldntCreateCodebase Pretty + +data InitResult m v a + = OpenedCodebase CodebasePath (FinalizerAndCodebase m v a) + | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) + | Error CodebasePath InitError + +createCodebaseWithResult :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (InitResult m v a) +createCodebaseWithResult cbInit debugName dir = + createCodebase cbInit debugName dir >>= \case + Left errorMessage -> do + pure (Error dir (CouldntCreateCodebase errorMessage)) + Right cb -> do + pure (CreatedCodebase dir cb) + +whenNoV1Codebase :: MonadIO m => CodebasePath -> m (InitResult m v a) -> m (InitResult m v a ) +whenNoV1Codebase dir initResult = + ifM (FCC.codebaseExists dir) + (pure (Error dir FoundV1Codebase)) + initResult + +openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseInitOptions -> m (InitResult m v a) +openOrCreateCodebase cbInit debugName initOptions = do + let resolvedPath = initOptionsToDir initOptions + openCodebase cbInit debugName resolvedPath >>= \case + Right cb -> pure (OpenedCodebase resolvedPath cb) + Left _ -> + case initOptions of + Home homeDir -> do + ifM (FCC.codebaseExists homeDir) + (do pure (Error homeDir FoundV1Codebase)) + (do + -- Create V2 codebase if neither a V1 or V2 exists + createCodebaseWithResult cbInit debugName homeDir + ) + + Specified specified -> + whenNoV1Codebase resolvedPath $ do + case specified of + DontCreateWhenMissing dir -> + pure (Error dir NoCodebaseFoundAtSpecifiedDir) + CreateWhenMissing dir -> + createCodebaseWithResult cbInit debugName dir + createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)) -createCodebase debugName cbInit path = do +createCodebase cbInit debugName path = do prettyDir <- P.string <$> canonicalizePath path - createCodebase' debugName cbInit path <&> mapLeft \case + createCodebase' cbInit debugName path <&> mapLeft \case CreateCodebaseAlreadyExists -> P.wrap $ "It looks like there's already a codebase in: " @@ -52,9 +125,9 @@ createCodebase debugName cbInit path = do -- previously: initCodebaseOrExit :: CodebasePath -> m (m (), Codebase m v a) -- previously: FileCodebase.initCodebase :: CodebasePath -> m (m (), Codebase m v a) openNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> m (m (), Codebase m Symbol Ann) -openNewUcmCodebaseOrExit debugName cbInit path = do +openNewUcmCodebaseOrExit cbInit debugName path = do prettyDir <- P.string <$> canonicalizePath path - createCodebase debugName cbInit path >>= \case + createCodebase cbInit debugName path >>= \case Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure Right x@(_, codebase) -> do liftIO $ @@ -66,6 +139,6 @@ openNewUcmCodebaseOrExit debugName cbInit path = do pure x -- | try to init a codebase where none exists and then exit regardless (i.e. `ucm -codebase dir init`) -initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () +initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () initCodebaseAndExit i debugName mdir = void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir diff --git a/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs b/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs new file mode 100644 index 0000000000..ce575001be --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError(..), Pretty) where + +import qualified Unison.Util.Pretty as P + +type Pretty = P.Pretty P.ColorText + +data CreateCodebaseError + = CreateCodebaseAlreadyExists + | CreateCodebaseOther Pretty diff --git a/parser-typechecker/src/Unison/Codebase/Init/Type.hs b/parser-typechecker/src/Unison/Codebase/Init/Type.hs new file mode 100644 index 0000000000..62d8c9d014 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Init/Type.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Unison.Codebase.Init.Type (Init(..)) where + +import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError, Pretty) +import Unison.Codebase (Codebase, CodebasePath) + +type DebugName = String + +data Init m v a = Init + { -- | open an existing codebase + openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + -- | create a new codebase + createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + -- | given a codebase root, and given that the codebase root may have other junk in it, + -- give the path to the "actual" files; e.g. what a forked transcript should clone. + codebasePath :: CodebasePath -> CodebasePath + } + diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index fda02c3772..578d240bd3 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -8,8 +8,7 @@ module Unison.Codebase.MainTerm where import Unison.Prelude -import Unison.Parser ( Ann ) -import qualified Unison.Parser as Parser +import Unison.Parser.Ann (Ann) import qualified Unison.Term as Term import Unison.Term ( Term ) import Unison.Var ( Var ) @@ -22,6 +21,7 @@ import Unison.Reference ( Reference ) import qualified Unison.Type as Type import Unison.Type ( Type ) import qualified Unison.Typechecker as Typechecker +import qualified Unison.Parser.Ann as Parser.Ann data MainTerm v = NotAFunctionName String @@ -41,7 +41,7 @@ getMainTerm loadTypeOfTerm parseNames0 mainName mainType = Nothing -> pure (NotAFunctionName mainName) Just hq -> do let refs = Names3.lookupHQTerm hq (Names3.Names parseNames0 mempty) - let a = Parser.External + let a = Parser.Ann.External case toList refs of [Referent.Ref ref] -> do typ <- loadTypeOfTerm ref diff --git a/parser-typechecker/src/Unison/Codebase/NameEdit.hs b/parser-typechecker/src/Unison/Codebase/NameEdit.hs deleted file mode 100644 index 3a872e1b0a..0000000000 --- a/parser-typechecker/src/Unison/Codebase/NameEdit.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Unison.Codebase.NameEdit where - -import Unison.Prelude - -import Unison.Reference (Reference) -import Unison.Hashable (Hashable, tokens) - -data NameEdit = - NameEdit { added :: Set Reference, removed :: Set Reference } - -instance Semigroup NameEdit where - NameEdit add1 del1 <> NameEdit add2 del2 = NameEdit (add1 <> add2) (del1 <> del2) - -instance Hashable NameEdit where - tokens (NameEdit added removed) = tokens (toList added, toList removed) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index d285fbf1d5..8d3d019a00 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -4,27 +4,80 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Path where - +module Unison.Codebase.Path + ( Path (..), + Path' (..), + Absolute (..), + Relative (..), + Resolve (..), + pattern Empty, + singleton, + Unison.Codebase.Path.uncons, + empty, + absoluteEmpty, + relativeEmpty', + currentPath, + prefix, + unprefix, + prefixName, + unprefixName, + HQSplit, + Split, + Split', + HQSplit', + ancestors, + + -- * tests + isCurrentPath, + isRoot, + isRoot', + + -- * things that could be replaced with `Convert` instances + absoluteToPath', + fromAbsoluteSplit, + fromList, + fromName, + fromName', + fromPath', + fromText, + toAbsoluteSplit, + toList, + toName, + toName', + toPath', + toText, + unsplit, + unsplit', + unsplitHQ, + unsplitHQ', + + -- * things that could be replaced with `Parse` instances + splitFromName, + hqSplitFromName', + + -- * things that could be replaced with `Cons` instances + cons, + + -- * things that could be replaced with `Snoc` instances + snoc, + unsnoc, + ) +where import Unison.Prelude hiding (empty, toList) -import Data.Bifunctor ( first ) -import Data.List.Extra ( stripPrefix, dropPrefix ) -import Control.Lens hiding (unsnoc, cons, snoc) +import Control.Lens hiding (Empty, cons, snoc, unsnoc) import qualified Control.Lens as Lens import qualified Data.Foldable as Foldable -import qualified Data.Text as Text -import Data.Sequence (Seq((:<|),(:|>) )) -import qualified Data.Sequence as Seq -import Unison.Name ( Name, Convert, Parse ) -import qualified Unison.Name as Name -import Unison.Util.Monoid (intercalateMap) -import qualified Unison.Lexer as Lexer +import Data.List.Extra (dropPrefix) +import Data.Sequence (Seq ((:<|), (:|>))) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text import qualified Unison.HashQualified' as HQ' -import qualified Unison.ShortHash as SH - -import Unison.NameSegment ( NameSegment(NameSegment)) -import qualified Unison.NameSegment as NameSegment +import Unison.Name (Convert, Name, Parse) +import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment (NameSegment)) +import qualified Unison.NameSegment as NameSegment +import Unison.Util.Monoid (intercalateMap) -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] newtype Path = Path { toSeq :: Seq NameSegment } deriving (Eq, Ord, Semigroup, Monoid) @@ -80,10 +133,9 @@ type HQSplit = (Path, HQ'.HQSegment) type Split' = (Path', NameSegment) type HQSplit' = (Path', HQ'.HQSegment) -type SplitAbsolute = (Absolute, NameSegment) type HQSplitAbsolute = (Absolute, HQ'.HQSegment) --- examples: +-- | examples: -- unprefix .foo.bar .blah == .blah (absolute paths left alone) -- unprefix .foo.bar id == id (relative paths starting w/ nonmatching prefix left alone) -- unprefix .foo.bar foo.bar.baz == baz (relative paths w/ common prefix get stripped) @@ -98,152 +150,10 @@ prefix (Absolute (Path prefix)) (Path' p) = case p of Left (unabsolute -> abs) -> abs Right (unrelative -> rel) -> Path $ prefix <> toSeq rel --- .libs.blah.poo is Absolute --- libs.blah.poo is Relative --- Left is some parse error tbd -parsePath' :: String -> Either String Path' -parsePath' p = case parsePathImpl' p of - Left e -> Left e - Right (p, "" ) -> Right p - Right (p, rem) -> case parseSegment rem of - Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg)) - Right (_, rem) -> - Left ("extra characters after " <> show p <> ": " <> show rem) - Left e -> Left e - --- implementation detail of parsePath' and parseSplit' --- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") --- foo.bar.baz becomes `Right (foo.bar, "baz") --- baz becomes `Right (, "baz") --- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths. --- TODO: Get rid of this thing. -parsePathImpl' :: String -> Either String (Path', String) -parsePathImpl' p = case p of - "." -> Right (Path' . Left $ absoluteEmpty, "") - '.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p - p -> over _1 (Path' . Right . Relative . fromList) <$> segs p - where - go f p = case f p of - Right (a, "") -> case Lens.unsnoc (Name.segments' $ Text.pack a) of - Nothing -> Left "empty path" - Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last) - Right (segs, '.' : rem) -> - let segs' = Name.segments' (Text.pack segs) - in Right (NameSegment <$> segs', rem) - Right (segs, rem) -> - Left $ "extra characters after " <> segs <> ": " <> show rem - Left e -> Left e - segs p = go parseSegment p - -parseSegment :: String -> Either String (String, String) -parseSegment s = - first show - . (Lexer.wordyId <> Lexer.symbolyId) - <> unit' - <> const (Left ("I expected an identifier but found " <> s)) - $ s - -wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment -wordyNameSegment s = case Lexer.wordyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem - -optionalWordyNameSegment :: String -> Either String NameSegment -optionalWordyNameSegment "" = Right $ NameSegment "" -optionalWordyNameSegment s = wordyNameSegment s - --- Parse a name segment like "()" -unit' :: String -> Either String (String, String) -unit' s = case stripPrefix "()" s of - Nothing -> Left $ "Expected () but found: " <> s - Just rem -> Right ("()", rem) - -unit :: String -> Either String NameSegment -unit s = case unit' s of - Right (_, "" ) -> Right $ NameSegment "()" - Right (_, rem) -> Left $ "trailing characters after (): " <> show rem - Left _ -> Left $ "I don't know how to parse " <> s - - -definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s - where - symbolyNameSegment s = case Lexer.symbolyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem - --- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz) --- parseSplit' wordyNameSegment "foo.bar.+" returns Left err --- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +) -parseSplit' :: (String -> Either String NameSegment) - -> String - -> Either String Split' -parseSplit' lastSegment p = do - (p', rem) <- parsePathImpl' p - seg <- lastSegment rem - pure (p', seg) - -parseShortHashOrHQSplit' :: String -> Either String (Either SH.ShortHash HQSplit') -parseShortHashOrHQSplit' s = - case Text.breakOn "#" $ Text.pack s of - ("","") -> error $ "encountered empty string parsing '" <> s <> "'" - (n,"") -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - pure $ Right (p, HQ'.NameOnly seg) - ("", sh) -> do - sh <- maybeToRight (shError s) . SH.fromText $ sh - pure $ Left sh - (n, sh) -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - hq <- maybeToRight (shError s) . - fmap (\sh -> (p, HQ'.HashQualified seg sh)) . - SH.fromText $ sh - pure $ Right hq - where - shError s = "couldn't parse shorthash from " <> s - -parseHQSplit :: String -> Either String HQSplit -parseHQSplit s = case parseHQSplit' s of - Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg) - Right (Path' Left{}, _) -> - Left $ "Sorry, you can't use an absolute name like " <> s <> " here." - Left e -> Left e - -parseHQSplit' :: String -> Either String HQSplit' -parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of - ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" - ("", _ ) -> Left "Sorry, you can't use a hash-only reference here." - (n , "") -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - pure (p, HQ'.NameOnly seg) - (n, sh) -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - maybeToRight (shError s) - . fmap (\sh -> (p, HQ'.HashQualified seg sh)) - . SH.fromText - $ sh - where - shError s = "couldn't parse shorthash from " <> s - parsePath n = do - x <- parsePathImpl' $ Text.unpack n - pure $ case x of - (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") - x -> x toAbsoluteSplit :: Absolute -> (Path', a) -> (Absolute, a) toAbsoluteSplit a (p, s) = (resolve a p, s) -fromSplit' :: (Path', a) -> (Path, a) -fromSplit' (Path' (Left (Absolute p)), a) = (p, a) -fromSplit' (Path' (Right (Relative p)), a) = (p, a) - fromAbsoluteSplit :: (Absolute, a) -> (Path, a) fromAbsoluteSplit (Absolute p, a) = (p, a) @@ -253,9 +163,6 @@ absoluteEmpty = Absolute empty relativeEmpty' :: Path' relativeEmpty' = Path' (Right (Relative empty)) -relativeSingleton :: NameSegment -> Relative -relativeSingleton = Relative . Path . Seq.singleton - toPath' :: Path -> Path' toPath' = \case Path (NameSegment "" :<| tail) -> Path' . Left . Absolute . Path $ tail @@ -282,6 +189,7 @@ hqSplitFromName' = fmap (fmap HQ'.fromName) . Lens.unsnoc . fromName' splitFromName :: Name -> Maybe Split splitFromName = unsnoc . fromName +-- | what is this? β€”AI unprefixName :: Absolute -> Name -> Name unprefixName prefix = toName . unprefix prefix . fromName' @@ -306,12 +214,6 @@ unsnoc = Lens.unsnoc uncons :: Path -> Maybe (NameSegment, Path) uncons = Lens.uncons ---asDirectory :: Path -> Text ---asDirectory p = case toList p of --- NameSegment "_root_" : (Seq.fromList -> tail) -> --- "/" <> asDirectory (Path tail) --- other -> Text.intercalate "/" . fmap NameSegment.toText $ other - -- > Path.fromName . Name.unsafeFromText $ ".Foo.bar" -- /Foo/bar -- Int./ -> "Int"/"/" @@ -339,17 +241,6 @@ toName = Name.unsafeFromText . toText toName' :: Path' -> Name toName' = Name.unsafeFromText . toText' --- Returns the nearest common ancestor, along with the --- two inputs relativized to that ancestor. -relativeToAncestor :: Path -> Path -> (Path, Path, Path) -relativeToAncestor (Path a) (Path b) = case (a, b) of - (ha :<| ta, hb :<| tb) | ha == hb -> - let (ancestor, relA, relB) = relativeToAncestor (Path ta) (Path tb) - in (ha `cons` ancestor, relA, relB) - -- nothing in common - _ -> (empty, Path a, Path b) - -pattern Parent h t = Path (NameSegment h :<| t) pattern Empty = Path Seq.Empty empty :: Path diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs new file mode 100644 index 0000000000..cc574f38b8 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Path.Parse + ( parsePath', + parsePathImpl', + parseSplit', + definitionNameSegment, + parseHQSplit, + parseHQSplit', + parseShortHashOrHQSplit', + wordyNameSegment, + ) +where + +import Unison.Prelude hiding (empty, toList) + +import Unison.Codebase.Path + +import Control.Lens (_1, over) +import qualified Control.Lens as Lens +import Data.Bifunctor (first) +import Data.List.Extra (stripPrefix) +import qualified Data.Text as Text +import qualified Unison.HashQualified' as HQ' +import qualified Unison.Lexer as Lexer +import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment (NameSegment)) +import qualified Unison.ShortHash as SH + +-- .libs.blah.poo is Absolute +-- libs.blah.poo is Relative +-- Left is some parse error tbd +parsePath' :: String -> Either String Path' +parsePath' p = case parsePathImpl' p of + Left e -> Left e + Right (p, "" ) -> Right p + Right (p, rem) -> case parseSegment rem of + Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg)) + Right (_, rem) -> + Left ("extra characters after " <> show p <> ": " <> show rem) + Left e -> Left e + +-- implementation detail of parsePath' and parseSplit' +-- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") +-- foo.bar.baz becomes `Right (foo.bar, "baz") +-- baz becomes `Right (, "baz") +-- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths. +-- TODO: Get rid of this thing. +parsePathImpl' :: String -> Either String (Path', String) +parsePathImpl' p = case p of + "." -> Right (Path' . Left $ absoluteEmpty, "") + '.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p + p -> over _1 (Path' . Right . Relative . fromList) <$> segs p + where + go f p = case f p of + Right (a, "") -> case Lens.unsnoc (Name.segments' $ Text.pack a) of + Nothing -> Left "empty path" + Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last) + Right (segs, '.' : rem) -> + let segs' = Name.segments' (Text.pack segs) + in Right (NameSegment <$> segs', rem) + Right (segs, rem) -> + Left $ "extra characters after " <> segs <> ": " <> show rem + Left e -> Left e + segs p = go parseSegment p + +parseSegment :: String -> Either String (String, String) +parseSegment s = + first show + . (Lexer.wordyId <> Lexer.symbolyId) + <> unit' + <> const (Left ("I expected an identifier but found " <> s)) + $ s + +wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment +wordyNameSegment s = case Lexer.wordyId0 s of + Left e -> Left (show e) + Right (a, "") -> Right (NameSegment (Text.pack a)) + Right (a, rem) -> + Left $ "trailing characters after " <> show a <> ": " <> show rem + +-- Parse a name segment like "()" +unit' :: String -> Either String (String, String) +unit' s = case stripPrefix "()" s of + Nothing -> Left $ "Expected () but found: " <> s + Just rem -> Right ("()", rem) + +unit :: String -> Either String NameSegment +unit s = case unit' s of + Right (_, "" ) -> Right $ NameSegment "()" + Right (_, rem) -> Left $ "trailing characters after (): " <> show rem + Left _ -> Left $ "I don't know how to parse " <> s + + +definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s + where + symbolyNameSegment s = case Lexer.symbolyId0 s of + Left e -> Left (show e) + Right (a, "") -> Right (NameSegment (Text.pack a)) + Right (a, rem) -> + Left $ "trailing characters after " <> show a <> ": " <> show rem + +-- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz) +-- parseSplit' wordyNameSegment "foo.bar.+" returns Left err +-- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +) +parseSplit' :: (String -> Either String NameSegment) + -> String + -> Either String Split' +parseSplit' lastSegment p = do + (p', rem) <- parsePathImpl' p + seg <- lastSegment rem + pure (p', seg) + +parseShortHashOrHQSplit' :: String -> Either String (Either SH.ShortHash HQSplit') +parseShortHashOrHQSplit' s = + case Text.breakOn "#" $ Text.pack s of + ("","") -> error $ "encountered empty string parsing '" <> s <> "'" + (n,"") -> do + (p, rem) <- parsePathImpl' (Text.unpack n) + seg <- definitionNameSegment rem + pure $ Right (p, HQ'.NameOnly seg) + ("", sh) -> do + sh <- maybeToRight (shError s) . SH.fromText $ sh + pure $ Left sh + (n, sh) -> do + (p, rem) <- parsePathImpl' (Text.unpack n) + seg <- definitionNameSegment rem + hq <- maybeToRight (shError s) . + fmap (\sh -> (p, HQ'.HashQualified seg sh)) . + SH.fromText $ sh + pure $ Right hq + where + shError s = "couldn't parse shorthash from " <> s + +parseHQSplit :: String -> Either String HQSplit +parseHQSplit s = case parseHQSplit' s of + Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg) + Right (Path' Left{}, _) -> + Left $ "Sorry, you can't use an absolute name like " <> s <> " here." + Left e -> Left e + +parseHQSplit' :: String -> Either String HQSplit' +parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of + ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" + ("", _ ) -> Left "Sorry, you can't use a hash-only reference here." + (n , "") -> do + (p, rem) <- parsePath n + seg <- definitionNameSegment rem + pure (p, HQ'.NameOnly seg) + (n, sh) -> do + (p, rem) <- parsePath n + seg <- definitionNameSegment rem + maybeToRight (shError s) + . fmap (\sh -> (p, HQ'.HashQualified seg sh)) + . SH.fromText + $ sh + where + shError s = "couldn't parse shorthash from " <> s + parsePath n = do + x <- parsePathImpl' $ Text.unpack n + pure $ case x of + (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") + x -> x diff --git a/parser-typechecker/src/Unison/Codebase/Reflog.hs b/parser-typechecker/src/Unison/Codebase/Reflog.hs index 07df0bd380..58b8f6bf40 100644 --- a/parser-typechecker/src/Unison/Codebase/Reflog.hs +++ b/parser-typechecker/src/Unison/Codebase/Reflog.hs @@ -1,30 +1,29 @@ {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Reflog where +module Unison.Codebase.Reflog (Entry(..), fromText, toText) where +import Data.Coerce (Coercible, coerce) import Data.Text (Text) import qualified Data.Text as Text -import Unison.Codebase.Branch (Hash) -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Hash as Hash -data Entry = - Entry - { from :: Hash - , to :: Hash - , reason :: Text - } +data Entry h = Entry + { from :: h, + to :: h, + reason :: Text + } -fromText :: Text -> Maybe Entry +fromText :: Coercible h Hash.Hash => Text -> Maybe (Entry h) fromText t = case Text.words t of (Hash.fromBase32Hex -> Just old) : (Hash.fromBase32Hex -> Just new) : (Text.unwords -> reason) -> - Just $ Entry (Causal.RawHash old) (Causal.RawHash new) reason + Just $ Entry (coerce old) (coerce new) reason _ -> Nothing - -toText :: Entry -> Text +toText :: Coercible h Hash.Hash => Entry h -> Text toText (Entry old new reason) = - Text.unwords [ Hash.base32Hex . Causal.unRawHash $ old - , Hash.base32Hex . Causal.unRawHash $ new - , reason ] + Text.unwords + [ Hash.base32Hex . coerce $ old, + Hash.base32Hex . coerce $ new, + reason + ] diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 653b8a7a24..de59541cbb 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -5,24 +5,25 @@ module Unison.Codebase.Runtime where import Unison.Prelude -import qualified Unison.ABT as ABT -import Data.Bifunctor (first) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Unison.Codebase.CodeLookup as CL -import qualified Unison.Codebase as Codebase -import Unison.UnisonFile ( UnisonFile ) -import Unison.Parser ( Ann ) -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import Unison.Var ( Var ) -import qualified Unison.Var as Var -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.UnisonFile as UF -import Unison.Builtin.Decls (pattern TupleTerm', tupleTerm) -import qualified Unison.Util.Pretty as P +import qualified Data.Map as Map +import qualified Unison.ABT as ABT +import Unison.Builtin.Decls (tupleTerm, pattern TupleTerm') +import qualified Unison.Codebase.CodeLookup as CL +import qualified Unison.Codebase.CodeLookup.Util as CL +import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.Parser.Ann (Ann) import qualified Unison.PrettyPrintEnv as PPE +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Term as Term +import Unison.Type (Type) +import Unison.UnisonFile (TypecheckedUnisonFile) +import qualified Unison.UnisonFile as UF +import qualified Unison.Util.Pretty as P +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unison.WatchKind (WatchKind) +import qualified Unison.WatchKind as WK type Error = P.Pretty P.ColorText type Term v = Term.Term v () @@ -36,7 +37,6 @@ data Runtime v = Runtime -> IO (Either Error (Term v)) , mainType :: Type v Ann , ioTestType :: Type v Ann - , needsContainment :: Bool } type IsCacheHit = Bool @@ -48,7 +48,7 @@ type WatchResults v a = (Either Error -- Bindings: ( [(v, Term v)] -- Map watchName (loc, hash, expression, value, isHit) - , Map v (a, UF.WatchKind, Reference, Term v, Term v, IsCacheHit) + , Map v (a, WatchKind, Reference, Term v, Term v, IsCacheHit) )) -- Evaluates the watch expressions in the file, returning a `Map` of their @@ -66,17 +66,17 @@ evaluateWatches -> PPE.PrettyPrintEnv -> (Reference -> IO (Maybe (Term v))) -> Runtime v - -> UnisonFile v a + -> TypecheckedUnisonFile v a -> IO (WatchResults v a) -evaluateWatches code ppe evaluationCache rt uf = do +evaluateWatches code ppe evaluationCache rt tuf = do -- 1. compute hashes for everything in the file let m :: Map v (Reference, Term.Term v a) - m = first Reference.DerivedId <$> - Term.hashComponents (Map.fromList (UF.terms uf <> UF.allWatches uf)) - watches = Set.fromList (fst <$> UF.allWatches uf) - watchKinds :: Map v UF.WatchKind - watchKinds = Map.fromList [ (v, k) | (k, ws) <- Map.toList (UF.watches uf) - , (v,_) <- ws ] + m = fmap (\(id, _wk, tm, _tp) -> (Reference.DerivedId id, tm)) (UF.hashTermsId tuf) + watches :: Set v = Map.keysSet watchKinds + watchKinds :: Map v WatchKind + watchKinds = + Map.fromList + [(v, k) | (k, ws) <- UF.watchComponents tuf, (v, _tm, _tp) <- ws] unann = Term.amap (const ()) -- 2. use the cache to lookup things already computed m' <- fmap Map.fromList . for (Map.toList m) $ \(v, (r, t)) -> do @@ -91,7 +91,7 @@ evaluateWatches code ppe evaluationCache rt uf = do bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ] watchVars = [ Term.var () v | v <- toList watches ] bigOl'LetRec = Term.letRec' True bindings (tupleTerm watchVars) - cl = void $ CL.fromUnisonFile uf <> code + cl = void (CL.fromTypecheckedUnisonFile tuf) <> void code -- 4. evaluate it and get all the results out of the tuple, then -- create the result Map out <- evaluate rt cl ppe bigOl'LetRec @@ -128,18 +128,15 @@ evaluateTerm' -> Term.Term v a -> IO (Either Error (Term v)) evaluateTerm' codeLookup cache ppe rt tm = do - let ref = Reference.DerivedId (Term.hashClosedTerm tm) + let ref = Reference.DerivedId (Hashing.hashClosedTerm tm) result <- cache ref case result of Just r -> pure (Right r) Nothing -> do - let uf = UF.UnisonFileId mempty mempty mempty - (Map.singleton UF.RegularWatch [(Var.nameds "result", tm)]) - runnable <- - if needsContainment rt - then Codebase.makeSelfContained' codeLookup uf - else pure uf - r <- evaluateWatches codeLookup ppe cache rt runnable + let + tuf = UF.typecheckedUnisonFile mempty mempty mempty + [(WK.RegularWatch, [(Var.nameds "result", tm, mempty <$> mainType rt)])] + r <- evaluateWatches (void codeLookup) ppe cache rt (void tuf) pure $ r <&> \(_,map) -> let [(_loc, _kind, _hash, _src, value, _isHit)] = Map.elems map in value diff --git a/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs b/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs deleted file mode 100644 index 57d2f645c0..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Unison.Codebase.Serialization.PutT where - -import Data.Bytes.Put -import qualified Data.Serialize.Put as Ser -import Data.Serialize.Put ( PutM - , runPutM - ) - -newtype PutT m a = PutT { unPutT :: m (PutM a) } - -instance Monad m => MonadPut (PutT m) where - putWord8 = PutT . pure . putWord8 - {-# INLINE putWord8 #-} - putByteString = PutT . pure . putByteString - {-# INLINE putByteString #-} - putLazyByteString = PutT . pure . putLazyByteString - {-# INLINE putLazyByteString #-} - flush = PutT $ pure flush - {-# INLINE flush #-} - putWord16le = PutT . pure . putWord16le - {-# INLINE putWord16le #-} - putWord16be = PutT . pure . putWord16be - {-# INLINE putWord16be #-} - putWord16host = PutT . pure . putWord16host - {-# INLINE putWord16host #-} - putWord32le = PutT . pure . putWord32le - {-# INLINE putWord32le #-} - putWord32be = PutT . pure . putWord32be - {-# INLINE putWord32be #-} - putWord32host = PutT . pure . putWord32host - {-# INLINE putWord32host #-} - putWord64le = PutT . pure . putWord64le - {-# INLINE putWord64le #-} - putWord64be = PutT . pure . putWord64be - {-# INLINE putWord64be #-} - putWord64host = PutT . pure . putWord64host - {-# INLINE putWord64host #-} - putWordhost = PutT . pure . putWordhost - {-# INLINE putWordhost #-} - -instance Functor m => Functor (PutT m) where - fmap f (PutT m) = PutT $ fmap (fmap f) m - -instance Applicative m => Applicative (PutT m) where - pure = PutT . pure . pure - (PutT f) <*> (PutT a) = PutT $ (<*>) <$> f <*> a - -instance Monad m => Monad (PutT m) where - (PutT m) >>= f = PutT $ do - putm <- m - let (a, bs) = runPutM putm - putm' <- unPutT $ f a - let (b, bs') = runPutM putm' - pure $ do - Ser.putByteString bs - Ser.putByteString bs' - pure b diff --git a/parser-typechecker/src/Unison/Codebase/Serialization/V1.hs b/parser-typechecker/src/Unison/Codebase/Serialization/V1.hs deleted file mode 100644 index 7793eff071..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Serialization/V1.hs +++ /dev/null @@ -1,826 +0,0 @@ -{-# LANGUAGE Strict #-} -{-# LANGUAGE RankNTypes #-} - -module Unison.Codebase.Serialization.V1 where - -import Unison.Prelude - -import Prelude hiding (getChar, putChar) - -import Basement.Block (Block) - --- import qualified Data.Text as Text -import qualified Unison.Pattern as Pattern -import Unison.Pattern ( Pattern - , SeqOp - ) -import Data.Bits ( Bits ) -import Data.Bytes.Get as Ser -import Data.Bytes.Put as Ser -import Data.Bytes.Serial ( serialize - , deserialize - , serializeBE - , deserializeBE - ) -import qualified Data.ByteArray as BA -import Data.Bytes.Signed ( Unsigned ) -import Data.Bytes.VarInt ( VarInt(..) ) -import qualified Data.Map as Map -import Data.List ( elemIndex - ) -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import Unison.Codebase.Causal ( Raw(..) - , RawHash(..) - , unRawHash - ) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Metadata as Metadata -import Unison.NameSegment as NameSegment -import Unison.Codebase.Patch ( Patch(..) ) -import qualified Unison.Codebase.Patch as Patch -import Unison.Codebase.TermEdit ( TermEdit ) -import Unison.Codebase.TypeEdit ( TypeEdit ) -import Unison.Hash ( Hash ) -import Unison.Kind ( Kind ) -import Unison.Reference ( Reference ) -import Unison.Symbol ( Symbol(..) ) -import Unison.Term ( Term ) -import qualified Data.ByteString as B -import qualified Data.Sequence as Sequence -import qualified Data.Set as Set -import qualified Unison.ABT as ABT -import qualified Unison.Codebase.TermEdit as TermEdit -import qualified Unison.Codebase.TypeEdit as TypeEdit -import qualified Unison.Codebase.Serialization as S -import qualified Unison.Hash as Hash -import qualified Unison.Kind as Kind -import qualified Unison.Reference as Reference -import Unison.Referent (Referent) -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import qualified Unison.Type as Type -import qualified Unison.Util.Bytes as Bytes -import Unison.Util.Star3 ( Star3 ) -import qualified Unison.Util.Star3 as Star3 -import Unison.Util.Relation ( Relation ) -import qualified Unison.Util.Relation as Relation -import qualified Unison.DataDeclaration as DataDeclaration -import Unison.DataDeclaration ( DataDeclaration - , EffectDeclaration - ) -import qualified Unison.Var as Var -import qualified Unison.ConstructorType as CT -import Unison.Type (Type) - --- ABOUT THIS FORMAT: --- --- A serialization format for uncompiled Unison syntax trees. --- --- Finalized: No --- --- If Finalized: Yes, don't modify this file in a way that affects serialized form. --- Instead, create a new file, V(n + 1). --- This ensures that we have a well-defined serialized form and can read --- and write old versions. - -unknownTag :: (MonadGet m, Show a) => String -> a -> m x -unknownTag msg tag = - fail $ "unknown tag " ++ show tag ++ - " while deserializing: " ++ msg - -putRawCausal :: MonadPut m => (a -> m ()) -> Causal.Raw h a -> m () -putRawCausal putA = \case - RawOne a -> putWord8 0 >> putA a - RawCons a t -> putWord8 1 >> (putHash . unRawHash) t >> putA a - RawMerge a ts -> - putWord8 2 >> putFoldable (putHash . unRawHash) ts >> putA a - -getCausal0 :: MonadGet m => m a -> m (Causal.Raw h a) -getCausal0 getA = getWord8 >>= \case - 0 -> RawOne <$> getA - 1 -> flip RawCons <$> (RawHash <$> getHash) <*> getA - 2 -> flip RawMerge . Set.fromList <$> getList (RawHash <$> getHash) <*> getA - x -> unknownTag "Causal0" x - --- Like getCausal, but doesn't bother to read the actual value in the causal, --- it just reads the hashes. Useful for more efficient implementation of --- `Causal.before`. --- getCausal00 :: MonadGet m => m Causal00 --- getCausal00 = getWord8 >>= \case --- 0 -> pure One00 --- 1 -> Cons00 <$> getHash --- 2 -> Merge00 . Set.fromList <$> getList getHash - --- 1. Can no longer read a causal using just MonadGet; --- need a way to construct the loader that forms its tail. --- Same problem with loading Branch0 with monadic tails. --- 2. Without the monadic tail, need external info to know how to --- load the tail. When modifying a nested structure, we --- need a way to save the intermediate nodes. (e.g. zipper?) --- 3. We ran into trouble trying to intermingle the marshalling monad --- (put/get) with the loading/saving monad (io). --- 4. PutT was weird because we don't think we want the Codebase monad to --- randomly be able to accumulate bytestrings (put) that don't even reset. --- 5. We could specialize `Causal m e` to a particular monad that tries to do --- the right things wrt caching? --- putCausal0 :: MonadPut m => Causal a -> (a -> m ()) -> m () --- putCausal0 = undefined - --- This loads the tail in order to write it? --- May be crucial to do so, if "loading" tail from `pure`, but --- otherwise weird. We'd like to skip writing the tail if it already --- exists, but how can we tell? --- Also, we're not even supposed to be writing the tail into the same buffer --- as head. We should be writing the hash of the tail though, so we can --- know which file we need to load it from; loading another file is also --- something we can't do in this model. ----- --- putCausal :: (MonadPut m, Monad n) => Causal n a -> (a -> m ()) -> n (m ()) --- putCausal (Causal.One hash a) putA = --- pure $ putWord8 1 *> putHash hash *> putA a --- putCausal (Causal.ConsN m) putA = do --- (conss, tail) <- m --- pure (putWord8 2 *> putFoldable conss (putPair' putHash putA)) --- *> putCausal tail putA --- putCausal (Causal.Merge hash a tails) putA = do --- pure (putWord8 3 *> putHash hash *> putA a) --- putFoldableN (Map.toList tails) $ putPair'' putHash (>>= (`putCausal` putA)) --- putCausal (Causal.Cons _ _ _) _ = --- error "deserializing 'Causal': the ConsN pattern should have matched here!" - - --- getCausal :: MonadGet m => m a -> m (Causal a) --- getCausal getA = getWord8 >>= \case --- 1 -> Causal.One <$> getHash <*> getA --- 2 -> Causal.consN <$> getList (getPair getHash getA) <*> getCausal getA --- 3 -> Causal.Merge <$> getHash <*> getA <*> --- (Map.fromList <$> getList (getPair getHash $ getCausal getA)) --- x -> unknownTag "causal" x - --- getCausal :: - -putLength :: - (MonadPut m, Integral n, Integral (Unsigned n), - Bits n, Bits (Unsigned n)) - => n -> m () -putLength = serialize . VarInt - -getLength :: - (MonadGet m, Integral n, Integral (Unsigned n), - Bits n, Bits (Unsigned n)) - => m n -getLength = unVarInt <$> deserialize - -putText :: MonadPut m => Text -> m () -putText text = do - let bs = encodeUtf8 text - putLength $ B.length bs - putByteString bs - -getText :: MonadGet m => m Text -getText = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ decodeUtf8 bs - -skipText :: MonadGet m => m () -skipText = do - len <- getLength - void $ Ser.getBytes len - -putFloat :: MonadPut m => Double -> m () -putFloat = serializeBE - -getFloat :: MonadGet m => m Double -getFloat = deserializeBE - -putNat :: MonadPut m => Word64 -> m () -putNat = putWord64be - -getNat :: MonadGet m => m Word64 -getNat = getWord64be - -putInt :: MonadPut m => Int64 -> m () -putInt = serializeBE - -getInt :: MonadGet m => m Int64 -getInt = deserializeBE - -putBoolean :: MonadPut m => Bool -> m () -putBoolean False = putWord8 0 -putBoolean True = putWord8 1 - -getBoolean :: MonadGet m => m Bool -getBoolean = go =<< getWord8 where - go 0 = pure False - go 1 = pure True - go t = unknownTag "Boolean" t - -putHash :: MonadPut m => Hash -> m () -putHash h = do - let bs = Hash.toBytes h - putLength (B.length bs) - putByteString bs - -getHash :: MonadGet m => m Hash -getHash = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ Hash.fromBytes bs - -putReference :: MonadPut m => Reference -> m () -putReference r = case r of - Reference.Builtin name -> do - putWord8 0 - putText name - Reference.Derived hash i n -> do - putWord8 1 - putHash hash - putLength i - putLength n - -getReference :: MonadGet m => m Reference -getReference = do - tag <- getWord8 - case tag of - 0 -> Reference.Builtin <$> getText - 1 -> Reference.DerivedId <$> (Reference.Id <$> getHash <*> getLength <*> getLength) - _ -> unknownTag "Reference" tag - -putReferent :: MonadPut m => Referent -> m () -putReferent = \case - Referent.Ref r -> do - putWord8 0 - putReference r - Referent.Con r i ct -> do - putWord8 1 - putReference r - putLength i - putConstructorType ct - -putConstructorType :: MonadPut m => CT.ConstructorType -> m () -putConstructorType = \case - CT.Data -> putWord8 0 - CT.Effect -> putWord8 1 - -getReferent :: MonadGet m => m Referent -getReferent = do - tag <- getWord8 - case tag of - 0 -> Referent.Ref <$> getReference - 1 -> Referent.Con <$> getReference <*> getLength <*> getConstructorType - _ -> unknownTag "getReferent" tag - -getConstructorType :: MonadGet m => m CT.ConstructorType -getConstructorType = getWord8 >>= \case - 0 -> pure CT.Data - 1 -> pure CT.Effect - t -> unknownTag "getConstructorType" t - -putMaybe :: MonadPut m => Maybe a -> (a -> m ()) -> m () -putMaybe Nothing _ = putWord8 0 -putMaybe (Just a) putA = putWord8 1 *> putA a - -getMaybe :: MonadGet m => m a -> m (Maybe a) -getMaybe getA = getWord8 >>= \tag -> case tag of - 0 -> pure Nothing - 1 -> Just <$> getA - _ -> unknownTag "Maybe" tag - -putFoldable - :: (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () -putFoldable putA as = do - putLength (length as) - traverse_ putA as - - --- putFoldableN --- :: forall f m n a --- . (Traversable f, MonadPut m, Applicative n) --- => f a --- -> (a -> n (m ())) --- -> n (m ()) --- putFoldableN as putAn = --- pure (putLength @m (length as)) *> (fmap sequence_ $ traverse putAn as) - -getFolded :: MonadGet m => (b -> a -> b) -> b -> m a -> m b -getFolded f z a = - foldl' f z <$> getList a - -getList :: MonadGet m => m a -> m [a] -getList a = getLength >>= (`replicateM` a) - -putABT - :: (MonadPut m, Foldable f, Functor f, Ord v) - => (v -> m ()) - -> (a -> m ()) - -> (forall x . (x -> m ()) -> f x -> m ()) - -> ABT.Term f v a - -> m () -putABT putVar putA putF abt = - putFoldable putVar fvs *> go (ABT.annotateBound'' abt) - where - fvs = Set.toList $ ABT.freeVars abt - go (ABT.Term _ (a, env) abt) = putA a *> case abt of - ABT.Var v -> putWord8 0 *> putVarRef env v - ABT.Tm f -> putWord8 1 *> putF go f - ABT.Abs v body -> putWord8 2 *> putVar v *> go body - ABT.Cycle body -> putWord8 3 *> go body - - putVarRef env v = case v `elemIndex` env of - Just i -> putWord8 0 *> putLength i - Nothing -> case v `elemIndex` fvs of - Just i -> putWord8 1 *> putLength i - Nothing -> error "impossible: var not free or bound" - -getABT - :: (MonadGet m, Foldable f, Functor f, Ord v) - => m v - -> m a - -> (forall x . m x -> m (f x)) - -> m (ABT.Term f v a) -getABT getVar getA getF = getList getVar >>= go [] where - go env fvs = do - a <- getA - tag <- getWord8 - case tag of - 0 -> do - tag <- getWord8 - case tag of - 0 -> ABT.annotatedVar a . (env !!) <$> getLength - 1 -> ABT.annotatedVar a . (fvs !!) <$> getLength - _ -> unknownTag "getABT.Var" tag - 1 -> ABT.tm' a <$> getF (go env fvs) - 2 -> do - v <- getVar - body <- go (v:env) fvs - pure $ ABT.abs' a v body - 3 -> ABT.cycle' a <$> go env fvs - _ -> unknownTag "getABT" tag - -putKind :: MonadPut m => Kind -> m () -putKind k = case k of - Kind.Star -> putWord8 0 - Kind.Arrow i o -> putWord8 1 *> putKind i *> putKind o - -getKind :: MonadGet m => m Kind -getKind = getWord8 >>= \tag -> case tag of - 0 -> pure Kind.Star - 1 -> Kind.Arrow <$> getKind <*> getKind - _ -> unknownTag "getKind" tag - -putType :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> Type v a - -> m () -putType putVar putA = putABT putVar putA go where - go putChild t = case t of - Type.Ref r -> putWord8 0 *> putReference r - Type.Arrow i o -> putWord8 1 *> putChild i *> putChild o - Type.Ann t k -> putWord8 2 *> putChild t *> putKind k - Type.App f x -> putWord8 3 *> putChild f *> putChild x - Type.Effect e t -> putWord8 4 *> putChild e *> putChild t - Type.Effects es -> putWord8 5 *> putFoldable putChild es - Type.Forall body -> putWord8 6 *> putChild body - Type.IntroOuter body -> putWord8 7 *> putChild body - -getType :: (MonadGet m, Ord v) - => m v -> m a -> m (Type v a) -getType getVar getA = getABT getVar getA go where - go getChild = getWord8 >>= \tag -> case tag of - 0 -> Type.Ref <$> getReference - 1 -> Type.Arrow <$> getChild <*> getChild - 2 -> Type.Ann <$> getChild <*> getKind - 3 -> Type.App <$> getChild <*> getChild - 4 -> Type.Effect <$> getChild <*> getChild - 5 -> Type.Effects <$> getList getChild - 6 -> Type.Forall <$> getChild - 7 -> Type.IntroOuter <$> getChild - _ -> unknownTag "getType" tag - -putSymbol :: MonadPut m => Symbol -> m () -putSymbol (Symbol id typ) = putLength id *> putText (Var.rawName typ) - -getSymbol :: MonadGet m => m Symbol -getSymbol = Symbol <$> getLength <*> (Var.User <$> getText) - -putPattern :: MonadPut m => (a -> m ()) -> Pattern a -> m () -putPattern putA p = case p of - Pattern.Unbound a -> putWord8 0 *> putA a - Pattern.Var a -> putWord8 1 *> putA a - Pattern.Boolean a b -> putWord8 2 *> putA a *> putBoolean b - Pattern.Int a n -> putWord8 3 *> putA a *> putInt n - Pattern.Nat a n -> putWord8 4 *> putA a *> putNat n - Pattern.Float a n -> putWord8 5 *> putA a *> putFloat n - Pattern.Constructor a r cid ps -> - putWord8 6 - *> putA a - *> putReference r - *> putLength cid - *> putFoldable (putPattern putA) ps - Pattern.As a p -> putWord8 7 *> putA a *> putPattern putA p - Pattern.EffectPure a p -> putWord8 8 *> putA a *> putPattern putA p - Pattern.EffectBind a r cid args k -> - putWord8 9 - *> putA a - *> putReference r - *> putLength cid - *> putFoldable (putPattern putA) args - *> putPattern putA k - Pattern.SequenceLiteral a ps -> - putWord8 10 *> putA a *> putFoldable (putPattern putA) ps - Pattern.SequenceOp a l op r -> - putWord8 11 - *> putA a - *> putPattern putA l - *> putSeqOp op - *> putPattern putA r - Pattern.Text a t -> putWord8 12 *> putA a *> putText t - Pattern.Char a c -> putWord8 13 *> putA a *> putChar c - -putSeqOp :: MonadPut m => SeqOp -> m () -putSeqOp Pattern.Cons = putWord8 0 -putSeqOp Pattern.Snoc = putWord8 1 -putSeqOp Pattern.Concat = putWord8 2 - -getSeqOp :: MonadGet m => m SeqOp -getSeqOp = getWord8 >>= \case - 0 -> pure Pattern.Cons - 1 -> pure Pattern.Snoc - 2 -> pure Pattern.Concat - tag -> unknownTag "SeqOp" tag - -getPattern :: MonadGet m => m a -> m (Pattern a) -getPattern getA = getWord8 >>= \tag -> case tag of - 0 -> Pattern.Unbound <$> getA - 1 -> Pattern.Var <$> getA - 2 -> Pattern.Boolean <$> getA <*> getBoolean - 3 -> Pattern.Int <$> getA <*> getInt - 4 -> Pattern.Nat <$> getA <*> getNat - 5 -> Pattern.Float <$> getA <*> getFloat - 6 -> Pattern.Constructor <$> getA <*> getReference <*> getLength <*> getList - (getPattern getA) - 7 -> Pattern.As <$> getA <*> getPattern getA - 8 -> Pattern.EffectPure <$> getA <*> getPattern getA - 9 -> - Pattern.EffectBind - <$> getA - <*> getReference - <*> getLength - <*> getList (getPattern getA) - <*> getPattern getA - 10 -> Pattern.SequenceLiteral <$> getA <*> getList (getPattern getA) - 11 -> - Pattern.SequenceOp - <$> getA - <*> getPattern getA - <*> getSeqOp - <*> getPattern getA - 12 -> Pattern.Text <$> getA <*> getText - 13 -> Pattern.Char <$> getA <*> getChar - _ -> unknownTag "Pattern" tag - -putTerm :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> Term v a - -> m () -putTerm putVar putA = putABT putVar putA go where - go putChild t = case t of - Term.Int n - -> putWord8 0 *> putInt n - Term.Nat n - -> putWord8 1 *> putNat n - Term.Float n - -> putWord8 2 *> putFloat n - Term.Boolean b - -> putWord8 3 *> putBoolean b - Term.Text t - -> putWord8 4 *> putText t - Term.Blank _ - -> error "can't serialize term with blanks" - Term.Ref r - -> putWord8 5 *> putReference r - Term.Constructor r cid - -> putWord8 6 *> putReference r *> putLength cid - Term.Request r cid - -> putWord8 7 *> putReference r *> putLength cid - Term.Handle h a - -> putWord8 8 *> putChild h *> putChild a - Term.App f arg - -> putWord8 9 *> putChild f *> putChild arg - Term.Ann e t - -> putWord8 10 *> putChild e *> putType putVar putA t - Term.List vs - -> putWord8 11 *> putFoldable putChild vs - Term.If cond t f - -> putWord8 12 *> putChild cond *> putChild t *> putChild f - Term.And x y - -> putWord8 13 *> putChild x *> putChild y - Term.Or x y - -> putWord8 14 *> putChild x *> putChild y - Term.Lam body - -> putWord8 15 *> putChild body - Term.LetRec _ bs body - -> putWord8 16 *> putFoldable putChild bs *> putChild body - Term.Let _ b body - -> putWord8 17 *> putChild b *> putChild body - Term.Match s cases - -> putWord8 18 *> putChild s *> putFoldable (putMatchCase putA putChild) cases - Term.Char c - -> putWord8 19 *> putChar c - Term.TermLink r - -> putWord8 20 *> putReferent r - Term.TypeLink r - -> putWord8 21 *> putReference r - - putMatchCase :: MonadPut m => (a -> m ()) -> (x -> m ()) -> Term.MatchCase a x -> m () - putMatchCase putA putChild (Term.MatchCase pat guard body) = - putPattern putA pat *> putMaybe guard putChild *> putChild body - -getTerm :: (MonadGet m, Ord v) - => m v -> m a -> m (Term v a) -getTerm getVar getA = getABT getVar getA go where - go getChild = getWord8 >>= \tag -> case tag of - 0 -> Term.Int <$> getInt - 1 -> Term.Nat <$> getNat - 2 -> Term.Float <$> getFloat - 3 -> Term.Boolean <$> getBoolean - 4 -> Term.Text <$> getText - 5 -> Term.Ref <$> getReference - 6 -> Term.Constructor <$> getReference <*> getLength - 7 -> Term.Request <$> getReference <*> getLength - 8 -> Term.Handle <$> getChild <*> getChild - 9 -> Term.App <$> getChild <*> getChild - 10 -> Term.Ann <$> getChild <*> getType getVar getA - 11 -> Term.List . Sequence.fromList <$> getList getChild - 12 -> Term.If <$> getChild <*> getChild <*> getChild - 13 -> Term.And <$> getChild <*> getChild - 14 -> Term.Or <$> getChild <*> getChild - 15 -> Term.Lam <$> getChild - 16 -> Term.LetRec False <$> getList getChild <*> getChild - 17 -> Term.Let False <$> getChild <*> getChild - 18 -> Term.Match <$> getChild - <*> getList (Term.MatchCase <$> getPattern getA <*> getMaybe getChild <*> getChild) - 19 -> Term.Char <$> getChar - 20 -> Term.TermLink <$> getReferent - 21 -> Term.TypeLink <$> getReference - _ -> unknownTag "getTerm" tag - -putPair :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a,b) -> m () -putPair putA putB (a,b) = putA a *> putB b - -putPair'' - :: (MonadPut m, Monad n) - => (a -> m ()) - -> (b -> n (m ())) - -> (a, b) - -> n (m ()) -putPair'' putA putBn (a, b) = pure (putA a) *> putBn b - -getPair :: MonadGet m => m a -> m b -> m (a,b) -getPair = liftA2 (,) - -putTuple3' - :: MonadPut m - => (a -> m ()) - -> (b -> m ()) - -> (c -> m ()) - -> (a, b, c) - -> m () -putTuple3' putA putB putC (a, b, c) = putA a *> putB b *> putC c - -getTuple3 :: MonadGet m => m a -> m b -> m c -> m (a,b,c) -getTuple3 = liftA3 (,,) - -putRelation :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Relation a b -> m () -putRelation putA putB r = putFoldable (putPair putA putB) (Relation.toList r) - -getRelation :: (MonadGet m, Ord a, Ord b) => m a -> m b -> m (Relation a b) -getRelation getA getB = Relation.fromList <$> getList (getPair getA getB) - -putMap :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Map a b -> m () -putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m) - -getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b) -getMap getA getB = Map.fromList <$> getList (getPair getA getB) - -putTermEdit :: MonadPut m => TermEdit -> m () -putTermEdit (TermEdit.Replace r typing) = - putWord8 1 *> putReference r *> case typing of - TermEdit.Same -> putWord8 1 - TermEdit.Subtype -> putWord8 2 - TermEdit.Different -> putWord8 3 -putTermEdit TermEdit.Deprecate = putWord8 2 - -getTermEdit :: MonadGet m => m TermEdit -getTermEdit = getWord8 >>= \case - 1 -> TermEdit.Replace <$> getReference <*> (getWord8 >>= \case - 1 -> pure TermEdit.Same - 2 -> pure TermEdit.Subtype - 3 -> pure TermEdit.Different - t -> unknownTag "TermEdit.Replace" t - ) - 2 -> pure TermEdit.Deprecate - t -> unknownTag "TermEdit" t - -putTypeEdit :: MonadPut m => TypeEdit -> m () -putTypeEdit (TypeEdit.Replace r) = putWord8 1 *> putReference r -putTypeEdit TypeEdit.Deprecate = putWord8 2 - -getTypeEdit :: MonadGet m => m TypeEdit -getTypeEdit = getWord8 >>= \case - 1 -> TypeEdit.Replace <$> getReference - 2 -> pure TypeEdit.Deprecate - t -> unknownTag "TypeEdit" t - -putStar3 - :: MonadPut m - => (f -> m ()) - -> (d1 -> m ()) - -> (d2 -> m ()) - -> (d3 -> m ()) - -> Star3 f d1 d2 d3 - -> m () -putStar3 putF putD1 putD2 putD3 s = do - putFoldable putF (Star3.fact s) - putRelation putF putD1 (Star3.d1 s) - putRelation putF putD2 (Star3.d2 s) - putRelation putF putD3 (Star3.d3 s) - -getStar3 - :: (MonadGet m, Ord fact, Ord d1, Ord d2, Ord d3) - => m fact - -> m d1 - -> m d2 - -> m d3 - -> m (Star3 fact d1 d2 d3) -getStar3 getF getD1 getD2 getD3 = - Star3.Star3 - <$> (Set.fromList <$> getList getF) - <*> getRelation getF getD1 - <*> getRelation getF getD2 - <*> getRelation getF getD3 - -putBranchStar :: MonadPut m => (a -> m ()) -> (n -> m ()) -> Branch.Star a n -> m () -putBranchStar putA putN = - putStar3 putA putN putMetadataType (putPair putMetadataType putMetadataValue) - -getBranchStar :: (Ord a, Ord n, MonadGet m) => m a -> m n -> m (Branch.Star a n) -getBranchStar getA getN = getStar3 getA getN getMetadataType (getPair getMetadataType getMetadataValue) - -putLink :: MonadPut m => (Hash, mb) -> m () -putLink (h, _) = do - -- 0 means local; later we may have remote links with other ids - putWord8 0 - putHash h - -putChar :: MonadPut m => Char -> m () -putChar = serialize . VarInt . fromEnum - -getChar :: MonadGet m => m Char -getChar = toEnum . unVarInt <$> deserialize - -putNameSegment :: MonadPut m => NameSegment -> m () -putNameSegment = putText . NameSegment.toText - -getNameSegment :: MonadGet m => m NameSegment -getNameSegment = NameSegment <$> getText - -putRawBranch :: MonadPut m => Branch.Raw -> m () -putRawBranch (Branch.Raw terms types children edits) = do - putBranchStar putReferent putNameSegment terms - putBranchStar putReference putNameSegment types - putMap putNameSegment (putHash . unRawHash) children - putMap putNameSegment putHash edits - -getMetadataType :: MonadGet m => m Metadata.Type -getMetadataType = getReference - -putMetadataType :: MonadPut m => Metadata.Type -> m () -putMetadataType = putReference - -getMetadataValue :: MonadGet m => m Metadata.Value -getMetadataValue = getReference - -putMetadataValue :: MonadPut m => Metadata.Value -> m () -putMetadataValue = putReference - -getRawBranch :: MonadGet m => m Branch.Raw -getRawBranch = - Branch.Raw - <$> getBranchStar getReferent getNameSegment - <*> getBranchStar getReference getNameSegment - <*> getMap getNameSegment (RawHash <$> getHash) - <*> getMap getNameSegment getHash - --- `getBranchDependencies` consumes the same data as `getRawBranch` -getBranchDependencies :: MonadGet m => m (BD.Branches n, BD.Dependencies) -getBranchDependencies = do - (terms1, types1) <- getTermStarDependencies - (terms2, types2) <- getTypeStarDependencies - childHashes <- fmap (RawHash . snd) <$> getList (getPair skipText getHash) - editHashes <- Set.fromList . fmap snd <$> getList (getPair skipText getHash) - pure ( childHashes `zip` repeat Nothing - , BD.Dependencies editHashes (terms1 <> terms2) (types1 <> types2) ) - where - -- returns things, metadata types, metadata values - getStarReferences :: - (MonadGet m, Ord r) => m r -> m ([r], [Metadata.Value]) - getStarReferences getR = do - void $ getList getR -- throw away the `facts` - -- d1: references and namesegments - rs :: [r] <- fmap fst <$> getList (getPair getR skipText) - -- d2: metadata type index - void $ getList (getPair getR getMetadataType) - -- d3: metadata (type, value) index - (_metadataTypes, metadataValues) <- unzip . fmap snd <$> - getList (getPair getR (getPair getMetadataType getMetadataValue)) - pure (rs, metadataValues) - - getTermStarDependencies :: MonadGet m => m (Set Reference.Id, Set Reference.Id) - getTermStarDependencies = do - (referents, mdValues) <- getStarReferences getReferent - let termIds = Set.fromList $ - [ i | Referent.Ref (Reference.DerivedId i) <- referents ] ++ - [ i | Reference.DerivedId i <- mdValues ] - declIds = Set.fromList $ - [ i | Referent.Con (Reference.DerivedId i) _cid _ct <- referents ] - pure (termIds, declIds) - - getTypeStarDependencies :: MonadGet m => m (Set Reference.Id, Set Reference.Id) - getTypeStarDependencies = do - (references, mdValues) <- getStarReferences getReference - let termIds = Set.fromList $ [ i | Reference.DerivedId i <- mdValues ] - declIds = Set.fromList $ [ i | Reference.DerivedId i <- references ] - pure (termIds, declIds) - -putDataDeclaration :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> DataDeclaration v a - -> m () -putDataDeclaration putV putA decl = do - putModifier $ DataDeclaration.modifier decl - putA $ DataDeclaration.annotation decl - putFoldable putV (DataDeclaration.bound decl) - putFoldable (putTuple3' putA putV (putType putV putA)) (DataDeclaration.constructors' decl) - -getDataDeclaration :: (MonadGet m, Ord v) => m v -> m a -> m (DataDeclaration v a) -getDataDeclaration getV getA = DataDeclaration.DataDeclaration <$> - getModifier <*> - getA <*> - getList getV <*> - getList (getTuple3 getA getV (getType getV getA)) - -putModifier :: MonadPut m => DataDeclaration.Modifier -> m () -putModifier DataDeclaration.Structural = putWord8 0 -putModifier (DataDeclaration.Unique txt) = putWord8 1 *> putText txt - -getModifier :: MonadGet m => m DataDeclaration.Modifier -getModifier = getWord8 >>= \case - 0 -> pure DataDeclaration.Structural - 1 -> DataDeclaration.Unique <$> getText - tag -> unknownTag "DataDeclaration.Modifier" tag - -putEffectDeclaration :: - (MonadPut m, Ord v) => (v -> m ()) -> (a -> m ()) -> EffectDeclaration v a -> m () -putEffectDeclaration putV putA (DataDeclaration.EffectDeclaration d) = - putDataDeclaration putV putA d - -getEffectDeclaration :: (MonadGet m, Ord v) => m v -> m a -> m (EffectDeclaration v a) -getEffectDeclaration getV getA = - DataDeclaration.EffectDeclaration <$> getDataDeclaration getV getA - -putEither :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> Either a b -> m () -putEither putL _ (Left a) = putWord8 0 *> putL a -putEither _ putR (Right b) = putWord8 1 *> putR b - -getEither :: MonadGet m => m a -> m b -> m (Either a b) -getEither getL getR = getWord8 >>= \case - 0 -> Left <$> getL - 1 -> Right <$> getR - tag -> unknownTag "Either" tag - -formatSymbol :: S.Format Symbol -formatSymbol = S.Format getSymbol putSymbol - -putEdits :: MonadPut m => Patch -> m () -putEdits edits = - putRelation putReference putTermEdit (Patch._termEdits edits) >> - putRelation putReference putTypeEdit (Patch._typeEdits edits) - -getEdits :: MonadGet m => m Patch -getEdits = Patch <$> getRelation getReference getTermEdit - <*> getRelation getReference getTypeEdit - -putBytes :: MonadPut m => Bytes.Bytes -> m () -putBytes = putFoldable putBlock . Bytes.chunks - -putBlock :: MonadPut m => Bytes.View (Block Word8) -> m () -putBlock b = putLength (BA.length b) *> putByteString (BA.convert b) - -getBytes :: MonadGet m => m Bytes.Bytes -getBytes = Bytes.fromChunks <$> getList getBlock - -getBlock :: MonadGet m => m (Bytes.View (Block Word8)) -getBlock = getLength >>= fmap (Bytes.view . BA.convert) . getByteString diff --git a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs index 8353ca6646..e71ef7adf5 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs @@ -4,11 +4,10 @@ module Unison.Codebase.ShortBranchHash where import Unison.Prelude -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Hash as Hash import qualified Data.Text as Text import qualified Data.Set as Set +import Data.Coerce (Coercible, coerce) newtype ShortBranchHash = ShortBranchHash { toText :: Text } -- base32hex characters @@ -17,15 +16,15 @@ newtype ShortBranchHash = toString :: ShortBranchHash -> String toString = Text.unpack . toText -toHash :: ShortBranchHash -> Maybe Branch.Hash -toHash = fmap Causal.RawHash . Hash.fromBase32Hex . toText +toHash :: Coercible Hash.Hash h => ShortBranchHash -> Maybe h +toHash = fmap coerce . Hash.fromBase32Hex . toText -fromHash :: Int -> Branch.Hash -> ShortBranchHash +fromHash :: Coercible h Hash.Hash => Int -> h -> ShortBranchHash fromHash len = - ShortBranchHash . Text.take len . Hash.base32Hex . Causal.unRawHash + ShortBranchHash . Text.take len . Hash.base32Hex . coerce -fullFromHash :: Branch.Hash -> ShortBranchHash -fullFromHash = ShortBranchHash . Hash.base32Hex . Causal.unRawHash +fullFromHash :: Coercible h Hash.Hash => h -> ShortBranchHash +fullFromHash = ShortBranchHash . Hash.base32Hex . coerce -- abc -> SBH abc -- #abc -> SBH abc diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 1c8eca35d7..46dc0f0abd 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -15,8 +15,9 @@ where import qualified Control.Concurrent import qualified Control.Exception +import Control.Exception.Safe (MonadCatch) import Control.Monad (filterM, unless, when, (>=>)) -import Control.Monad.Except (ExceptT(ExceptT), MonadError (throwError), runExceptT) +import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError), runExceptT, withExceptT) import qualified Control.Monad.Except as Except import Control.Monad.Extra (ifM, unlessM) import qualified Control.Monad.Extra as Monad @@ -26,10 +27,10 @@ import qualified Control.Monad.State as State import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import Data.Bifunctor (Bifunctor (bimap, first), second) -import qualified Data.Either.Combinators as Either import qualified Data.Char as Char +import qualified Data.Either.Combinators as Either import Data.Foldable (Foldable (toList), for_, traverse_) -import Data.Functor (void, (<&>), ($>)) +import Data.Functor (void, ($>), (<&>)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -47,12 +48,13 @@ import qualified System.Console.ANSI as ANSI import System.FilePath (()) import qualified System.FilePath as FilePath import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) -import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Reference as C.Reference import U.Codebase.Sqlite.Connection (Connection (Connection)) import qualified U.Codebase.Sqlite.Connection as Connection +import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import qualified U.Codebase.Sqlite.JournalMode as JournalMode import qualified U.Codebase.Sqlite.ObjectType as OT +import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 @@ -62,6 +64,7 @@ import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 import qualified U.Util.Monoid as Monoid import qualified U.Util.Set as Set +import U.Util.Timing (time) import qualified Unison.Builtin as Builtins import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase1 @@ -69,23 +72,24 @@ import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), writeToRead, printWriteRepo) -import Unison.Codebase.GitError (GitError) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), printWriteRepo, writeToRead) import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Init as Codebase -import qualified Unison.Codebase.Init as Codebase1 +import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 import Unison.Codebase.Patch (Patch) import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv +import qualified Unison.Codebase.SqliteCodebase.GitError as GitError import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) +import qualified Unison.Codebase.Type as C import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as Decl import Unison.Hash (Hash) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude (MaybeT (runMaybeT), fromMaybe, isJust, trace, traceM) import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -98,14 +102,11 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type -import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P -import U.Util.Timing (time) +import qualified Unison.WatchKind as UF import UnliftIO (MonadIO, catchIO, finally, liftIO) import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.STM -import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) -import Control.Exception.Safe (MonadCatch) debug, debugProcessBranches, debugCommitFailedTransaction :: Bool debug = False @@ -626,7 +627,7 @@ sqliteCodebase debugName root = do clearWatches :: MonadIO m => m () clearWatches = runDB conn Ops.clearWatches - getReflog :: MonadIO m => m [Reflog.Entry] + getReflog :: MonadIO m => m [Reflog.Entry Branch.Hash] getReflog = liftIO $ ( do @@ -695,7 +696,7 @@ sqliteCodebase debugName root = do >>= traverse (Cv.referentid2to1 (getCycleLen "referentsByPrefix") getDeclType) declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) let declReferents = - [ Referent.Con' (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct) + [ Referent.ConId (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct) | (h, pos, len, ct, cids) <- declReferents', cid <- cids ] @@ -993,15 +994,15 @@ viewRemoteBranch' :: forall m. (MonadIO m, MonadCatch m) => ReadRemoteNamespace -> - m (Either GitError (m (), Branch m, CodebasePath)) -viewRemoteBranch' (repo, sbh, path) = runExceptT do + m (Either C.GitError (m (), Branch m, CodebasePath)) +viewRemoteBranch' (repo, sbh, path) = runExceptT @C.GitError do -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch repo - ifM + remotePath <- time "Git fetch" . withExceptT C.GitProtocolError $ pullBranch repo + ifM @(ExceptT C.GitError m) (codebaseExists remotePath) do lift (sqliteCodebase "viewRemoteBranch.gitCache" remotePath) >>= \case - Left sv -> ExceptT . pure . Left $ GitError.UnrecognizedSchemaVersion repo remotePath sv + Left sv -> ExceptT . pure . Left . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath sv Right (closeCodebase, codebase) -> do -- try to load the requested branch from it branch <- time "Git fetch (sbh)" $ case sbh of @@ -1011,20 +1012,20 @@ viewRemoteBranch' (repo, sbh, path) = runExceptT do -- this NoRootBranch case should probably be an error too. Left Codebase1.NoRootBranch -> pure Branch.empty Left (Codebase1.CouldntLoadRootBranch h) -> - throwError $ GitError.CouldntLoadRootBranch repo h + throwError . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h Left (Codebase1.CouldntParseRootBranch s) -> - throwError $ GitError.CouldntParseRootBranch repo s + throwError . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s Right b -> pure b -- load from a specific `ShortBranchHash` Just sbh -> do branchCompletions <- lift $ Codebase1.branchHashesByPrefix codebase sbh case toList branchCompletions of - [] -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh + [] -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh [h] -> lift (Codebase1.getBranchForHash codebase h) >>= \case Just b -> pure b - Nothing -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh - _ -> throwError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions + Nothing -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh + _ -> throwError . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions pure (closeCodebase, Branch.getAt' path branch, remotePath) -- else there's no initialized codebase at this repo; we pretend there's an empty one. -- I'm thinking we should probably return an error value instead. @@ -1037,8 +1038,8 @@ pushGitRootBranch :: Connection -> Branch m -> WriteRepo -> - m (Either GitError ()) -pushGitRootBranch srcConn branch repo = runExceptT @GitError do + m (Either C.GitError ()) +pushGitRootBranch srcConn branch repo = runExceptT @C.GitError do -- pull the remote repo to the staging directory -- open a connection to the staging codebase -- create a savepoint on the staging codebase @@ -1048,7 +1049,7 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do -- if it fails, rollback to the savepoint and clean up. -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch (writeToRead repo) + remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo) destConn <- openOrCreateCodebaseConnection "push.dest" remotePath flip runReaderT destConn $ Q.savepoint "push" @@ -1073,7 +1074,7 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do ++ "." Just False -> do Q.rollbackRelease "push" - throwError $ GitError.PushDestinationHasNewStuff repo + throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo Just True -> do setRepoRoot newRootHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 0f029232c1..e1676aab9e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -48,8 +48,8 @@ import Unison.Hash (Hash) import qualified Unison.Hash as V1 import qualified Unison.Kind as V1.Kind import qualified Unison.NameSegment as V1 -import Unison.Parser (Ann) -import qualified Unison.Parser as Ann +import Unison.Parser.Ann (Ann) +import qualified Unison.Parser.Ann as Ann import qualified Unison.Pattern as V1.Pattern import qualified Unison.Reference as V1 import qualified Unison.Reference as V1.Reference @@ -60,8 +60,8 @@ import qualified Unison.Term as V1.Term import qualified Unison.Type as V1.Type import qualified Unison.Util.Relation as Relation import qualified Unison.Util.Star3 as V1.Star3 -import qualified Unison.Var as V1.Var import qualified Unison.Var as Var +import qualified Unison.WatchKind as V1.WK sbh1to2 :: V1.ShortBranchHash -> V2.ShortBranchHash sbh1to2 (V1.ShortBranchHash b32) = V2.ShortBranchHash b32 @@ -76,16 +76,16 @@ decltype1to2 = \case CT.Data -> V2.Decl.Data CT.Effect -> V2.Decl.Effect -watchKind1to2 :: V1.Var.WatchKind -> V2.WatchKind +watchKind1to2 :: V1.WK.WatchKind -> V2.WatchKind watchKind1to2 = \case - V1.Var.RegularWatch -> V2.WatchKind.RegularWatch - V1.Var.TestWatch -> V2.WatchKind.TestWatch + V1.WK.RegularWatch -> V2.WatchKind.RegularWatch + V1.WK.TestWatch -> V2.WatchKind.TestWatch other -> error $ "What kind of watchkind is " ++ other ++ "?" -watchKind2to1 :: V2.WatchKind -> V1.Var.WatchKind +watchKind2to1 :: V2.WatchKind -> V1.WK.WatchKind watchKind2to1 = \case - V2.WatchKind.RegularWatch -> V1.Var.RegularWatch - V2.WatchKind.TestWatch -> V1.Var.TestWatch + V2.WatchKind.RegularWatch -> V1.WK.RegularWatch + V2.WatchKind.TestWatch -> V1.WK.TestWatch term1to2 :: Hash -> V1.Term.Term V1.Symbol Ann -> V2.Term.Term V2.Symbol term1to2 h = @@ -342,9 +342,9 @@ referent1to2 = \case referentid2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id referentid2to1 lookupSize lookupCT = \case - V2.RefId r -> V1.Ref' <$> referenceid2to1 lookupSize r + V2.RefId r -> V1.RefId <$> referenceid2to1 lookupSize r V2.ConId r i -> - V1.Con' <$> referenceid2to1 lookupSize r + V1.ConId <$> referenceid2to1 lookupSize r <*> pure (fromIntegral i) <*> lookupCT (V2.ReferenceDerived r) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs new file mode 100644 index 0000000000..09b3eeb9ed --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs @@ -0,0 +1,10 @@ +module Unison.Codebase.SqliteCodebase.GitError where + +import Unison.Codebase.Editor.RemoteRepo (ReadRepo) +import Unison.CodebasePath (CodebasePath) +import U.Codebase.Sqlite.DbId (SchemaVersion) + +data GitSqliteCodebaseError + = GitCouldntParseRootBranchHash ReadRepo String + | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion + deriving Show diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/TermEdit.hs index 7e2239024f..df753c84c5 100644 --- a/parser-typechecker/src/Unison/Codebase/TermEdit.hs +++ b/parser-typechecker/src/Unison/Codebase/TermEdit.hs @@ -3,9 +3,6 @@ module Unison.Codebase.TermEdit where import Unison.Hashable (Hashable) import qualified Unison.Hashable as H import Unison.Reference (Reference) -import qualified Unison.Typechecker as Typechecker -import Unison.Type (Type) -import Unison.Var (Var) data TermEdit = Replace Reference Typing | Deprecate deriving (Eq, Ord, Show) @@ -43,9 +40,3 @@ isSame :: TermEdit -> Bool isSame e = case e of Replace _ Same -> True _ -> False - -typing :: Var v => Type v loc -> Type v loc -> Typing -typing newType oldType | Typechecker.isEqual newType oldType = Same - | Typechecker.isSubtype newType oldType = Subtype - | otherwise = Different - diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs b/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs new file mode 100644 index 0000000000..1d9db07a04 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs @@ -0,0 +1,12 @@ +module Unison.Codebase.TermEdit.Typing where + +import Unison.Codebase.TermEdit (Typing (Different, Same, Subtype)) +import Unison.Type (Type) +import qualified Unison.Typechecker as Typechecker +import Unison.Var (Var) + +typing :: Var v => Type v loc -> Type v loc -> Typing +typing newType oldType + | Typechecker.isEqual newType oldType = Same + | Typechecker.isSubtype newType oldType = Subtype + | otherwise = Different diff --git a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs index 99ae297906..74d2dc5759 100644 --- a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs +++ b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs @@ -25,11 +25,12 @@ import Unison.CommandLine import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal import Unison.Symbol (Symbol) -import Unison.CommandLine.Main (asciiartUnison, expandNumber) +import Unison.CommandLine.Main (expandNumber) +import Unison.CommandLine.Welcome (asciiartUnison) import qualified Data.Char as Char import qualified Data.Map as Map import qualified Data.Text as Text @@ -41,6 +42,7 @@ import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Runtime import qualified Unison.CommandLine.InputPattern as IP import qualified Unison.Runtime.Interface as RTI @@ -157,6 +159,10 @@ run dir configFile stanzas codebase = do -- end of ucm block Just Nothing -> do output "\n```\n" + -- We clear the file cache after each `ucm` stanza, so + -- that `load` command can read the file written by `edit` + -- rather than hitting the cache. + writeIORef unisonFiles Map.empty dieUnexpectedSuccess awaitInput -- ucm command to run diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs new file mode 100644 index 0000000000..01b6600c6b --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Type (Codebase (..), CodebasePath, GitError(..), GetRootBranchError (..), SyncToDir) where + +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo) +import Unison.Codebase.Patch (Patch) +import qualified Unison.Codebase.Reflog as Reflog +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.SyncMode (SyncMode) +import Unison.CodebasePath (CodebasePath) +import Unison.DataDeclaration (Decl) +import Unison.Prelude +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.ShortHash (ShortHash) +import Unison.Term (Term) +import Unison.Type (Type) +import qualified Unison.WatchKind as WK +import Unison.Codebase.GitError (GitProtocolError, GitCodebaseError) +import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError) + +type SyncToDir m = + CodebasePath -> -- dest codebase + SyncMode -> + Branch m -> -- branch to sync to dest codebase + m () + +-- | Abstract interface to a user's codebase. +-- +-- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. +data Codebase m v a = Codebase + { getTerm :: Reference.Id -> m (Maybe (Term v a)), + getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)), + getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), + putTerm :: Reference.Id -> Term v a -> Type v a -> m (), + putTypeDeclaration :: Reference.Id -> Decl v a -> m (), + getRootBranch :: m (Either GetRootBranchError (Branch m)), + putRootBranch :: Branch m -> m (), + rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), + getBranchForHashImpl :: Branch.Hash -> m (Maybe (Branch m)), + putBranch :: Branch m -> m (), + branchExists :: Branch.Hash -> m Bool, + getPatch :: Branch.EditHash -> m (Maybe Patch), + putPatch :: Branch.EditHash -> Patch -> m (), + patchExists :: Branch.EditHash -> m Bool, + dependentsImpl :: Reference -> m (Set Reference.Id), + -- This copies all the dependencies of `b` from the specified Codebase into this one + syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + -- This copies all the dependencies of `b` from this Codebase + syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)), + pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()), + -- Watch expressions are part of the codebase, the `Reference.Id` is + -- the hash of the source of the watch expression, and the `Term v a` + -- is the evaluated result of the expression, decompiled to a term. + watches :: WK.WatchKind -> m [Reference.Id], + getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)), + putWatch :: WK.WatchKind -> Reference.Id -> Term v a -> m (), + clearWatches :: m (), + getReflog :: m [Reflog.Entry Branch.Hash], + appendReflog :: Text -> Branch m -> Branch m -> m (), + -- list of terms of the given type + termsOfTypeImpl :: Reference -> m (Set Referent.Id), + -- list of terms that mention the given type anywhere in their signature + termsMentioningTypeImpl :: Reference -> m (Set Referent.Id), + -- number of base58 characters needed to distinguish any two references in the codebase + hashLength :: m Int, + termReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + termReferentsByPrefix :: ShortHash -> m (Set Referent.Id), + branchHashLength :: m Int, + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash), + -- returns `Nothing` to not implemented, fallback to in-memory + -- also `Nothing` if no LCA + -- The result is undefined if the two hashes are not in the codebase. + -- Use `Codebase.lca` which wraps this in a nice API. + lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)), + -- `beforeImpl` returns `Nothing` if not implemented by the codebase + -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase + -- + -- Use `Codebase.before` which wraps this in a nice API. + beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) + } + +data GetRootBranchError + = NoRootBranch + | CouldntParseRootBranch String + | CouldntLoadRootBranch Branch.Hash + deriving Show + +data GitError + = GitProtocolError GitProtocolError + | GitCodebaseError (GitCodebaseError Branch.Hash) + | GitSqliteCodebaseError GitSqliteCodebaseError + deriving Show diff --git a/parser-typechecker/src/Unison/Codebase/Verbosity.hs b/parser-typechecker/src/Unison/Codebase/Verbosity.hs new file mode 100644 index 0000000000..67dee2b532 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Verbosity.hs @@ -0,0 +1,9 @@ +module Unison.Codebase.Verbosity +where + +data Verbosity = Default | Silent deriving (Eq, Show) + +isSilent :: Verbosity -> Bool +isSilent v = case v of + Default -> False + Silent -> True diff --git a/parser-typechecker/src/Unison/CodebasePath.hs b/parser-typechecker/src/Unison/CodebasePath.hs new file mode 100644 index 0000000000..f9424cf32c --- /dev/null +++ b/parser-typechecker/src/Unison/CodebasePath.hs @@ -0,0 +1,13 @@ +module Unison.CodebasePath + ( CodebasePath, + getCodebaseDir, + ) +where + +import Control.Monad.IO.Class (MonadIO) +import UnliftIO.Directory (getHomeDirectory) + +type CodebasePath = FilePath + +getCodebaseDir :: MonadIO m => Maybe CodebasePath -> m CodebasePath +getCodebaseDir = maybe getHomeDirectory pure diff --git a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs index 5d6ccf1f19..cd5dfa6ab3 100644 --- a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs +++ b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs @@ -19,6 +19,8 @@ import qualified Unison.DataDeclaration as DD import qualified Unison.DeclPrinter as DP import qualified Unison.NamePrinter as NP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Referent as Referent import qualified Unison.Reference as Reference import qualified Unison.ShortHash as SH @@ -310,7 +312,7 @@ displayDoc pped terms typeOf evaluated types = go Referent.Con r _ _ -> prettyType r prettyType r = let ppe = PPE.declarationPPE pped r in types r >>= \case Nothing -> pure $ "😢 Missing type source for: " <> typeName ppe r - Just ty -> pure . P.syntaxToColor $ P.group $ DP.prettyDecl ppe r (PPE.typeName ppe r) ty + Just ty -> pure . P.syntaxToColor $ P.group $ DP.prettyDecl pped r (PPE.typeName ppe r) ty termName :: PPE.PrettyPrintEnv -> Referent -> Pretty termName ppe r = P.syntaxToColor $ diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index 1b26833767..4018a8f265 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -27,8 +27,11 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Text.Megaparsec as P import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.CommandLine.InputPattern as I import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' @@ -43,6 +46,8 @@ import qualified Unison.Codebase.Editor.UriParser as UriParser import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import Data.Tuple.Extra (uncurry3) +import Unison.Codebase.Verbosity (Verbosity) +import qualified Unison.Codebase.Verbosity as Verbosity showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = P.lines [ @@ -558,6 +563,13 @@ aliasMany = InputPattern "alias.many" ["copy"] _ -> Left (I.help aliasMany) ) +up :: InputPattern +up = InputPattern "up" [] [] + (P.wrapColumn2 [ (makeExample up [], "move current path up one level") ]) + (\case + [] -> Right Input.UpI + _ -> Left (I.help up) + ) cd :: InputPattern cd = InputPattern "namespace" ["cd", "j"] [(Required, pathArg)] @@ -567,6 +579,7 @@ cd = InputPattern "namespace" ["cd", "j"] [(Required, pathArg)] , (makeExample cd [".cat.dog"], "sets the current namespace to the abolute namespace .cat.dog.") ]) (\case + [".."] -> Right Input.UpI [p] -> first fromString $ do p <- Path.parsePath' p pure . Input.SwitchBranchI $ p @@ -698,49 +711,60 @@ resetRoot = InputPattern "reset-root" [] [(Required, pathArg)] pure $ Input.ResetRootI src _ -> Left (I.help resetRoot)) +pullSilent :: InputPattern +pullSilent = + pullImpl "pull.silent" Verbosity.Silent + pull :: InputPattern -pull = InputPattern - "pull" - [] - [(Optional, gitUrlArg), (Optional, pathArg)] - (P.lines - [ P.wrap - "The `pull` command merges a remote namespace into a local namespace." - , "" - , P.wrapColumn2 - [ ( "`pull remote local`" - , "merges the remote namespace `remote`" - <>"into the local namespace `local`." - ) - , ( "`pull remote`" - , "merges the remote namespace `remote`" - <>"into the current namespace") - , ( "`pull`" - , "merges the remote namespace configured in `.unisonConfig`" - <> "with the key `GitUrl.ns` where `ns` is the current namespace," - <> "into the current namespace") - ] - , "" - , P.wrap "where `remote` is a git repository, optionally followed by `:`" - <> "and an absolute remote path, such as:" - , P.indentN 2 . P.lines $ - [P.backticked "https://github.com/org/repo" - ,P.backticked "https://github.com/org/repo:.some.remote.path" - ] - ] - ) - (\case - [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit - [url] -> do - ns <- parseUri "url" url - Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit - [url, path] -> do - ns <- parseUri "url" url - p <- first fromString $ Path.parsePath' path - Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit - _ -> Left (I.help pull) - ) +pull = pullImpl "pull" Verbosity.Default + +pullImpl :: String -> Verbosity -> InputPattern +pullImpl name verbosity = do + self + where + addendum = if Verbosity.isSilent verbosity then "without listing the merged entities" else "" + self = InputPattern + name + [] + [(Optional, gitUrlArg), (Optional, pathArg)] + (P.lines + [ P.wrap + "The" <> makeExample' self <> "command merges a remote namespace into a local namespace" <> addendum + , "" + , P.wrapColumn2 + [ ( makeExample self ["remote", "local"] + , "merges the remote namespace `remote`" + <>"into the local namespace `local" + ) + , ( makeExample self ["remote"] + , "merges the remote namespace `remote`" + <>"into the current namespace") + , ( makeExample' self + , "merges the remote namespace configured in `.unisonConfig`" + <> "with the key `GitUrl.ns` where `ns` is the current namespace," + <> "into the current namespace") + ] + , "" + , P.wrap "where `remote` is a git repository, optionally followed by `:`" + <> "and an absolute remote path, such as:" + , P.indentN 2 . P.lines $ + [P.backticked "https://github.com/org/repo" + ,P.backticked "https://github.com/org/repo:.some.remote.path" + ] + ] + ) + (\case + [] -> + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit verbosity + [url] -> do + ns <- parseUri "url" url + Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit verbosity + [url, path] -> do + ns <- parseUri "url" url + p <- first fromString $ Path.parsePath' path + Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit verbosity + _ -> Left (I.help self) + ) pullExhaustive :: InputPattern pullExhaustive = InputPattern @@ -757,14 +781,14 @@ pullExhaustive = InputPattern ) (\case [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Verbosity.Default [url] -> do ns <- parseUri "url" url - Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete + Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Verbosity.Default [url, path] -> do ns <- parseUri "url" url p <- first fromString $ Path.parsePath' path - Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete + Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete Verbosity.Default _ -> Left (I.help pull) ) @@ -1291,12 +1315,6 @@ debugNumberedArgs = InputPattern "debug.numberedArgs" [] [] "Dump the contents of the numbered args state." (const $ Right Input.DebugNumberedArgsI) -debugBranchHistory :: InputPattern -debugBranchHistory = InputPattern "debug.history" [] - [(Optional, noCompletions)] - "Dump codebase history, compatible with bit-booster.com/graph.html" - (const $ Right Input.DebugBranchHistoryI) - debugFileHashes :: InputPattern debugFileHashes = InputPattern "debug.file" [] [] "View details about the most recent succesfully typechecked file." @@ -1394,11 +1412,13 @@ validInputs = , names , push , pull + , pullSilent , pushExhaustive , pullExhaustive , createPullRequest , loadPullRequest , cd + , up , back , deleteBranch , renameBranch @@ -1445,7 +1465,6 @@ validInputs = , mergeIOBuiltins , dependents, dependencies , debugNumberedArgs - , debugBranchHistory , debugFileHashes , debugDumpNamespace , debugDumpNamespaceSimple @@ -1574,8 +1593,9 @@ patternFromInput :: Input -> InputPattern patternFromInput = \case Input.PushRemoteBranchI _ _ SyncMode.ShortCircuit -> push Input.PushRemoteBranchI _ _ SyncMode.Complete -> pushExhaustive - Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit -> pull - Input.PullRemoteBranchI _ _ SyncMode.Complete -> pushExhaustive + Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit Verbosity.Default -> pull + Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit Verbosity.Silent -> pullSilent + Input.PullRemoteBranchI _ _ SyncMode.Complete _ -> pushExhaustive _ -> error "todo: finish this function" inputStringFromInput :: IsString s => Input -> P.Pretty s @@ -1584,7 +1604,7 @@ inputStringFromInput = \case (P.string . I.patternName $ patternFromInput i) <> (" " <> maybe mempty (P.text . uncurry RemoteRepo.printHead) rh) <> " " <> P.shown p' - i@(Input.PullRemoteBranchI ns p' _) -> + i@(Input.PullRemoteBranchI ns p' _ _) -> (P.string . I.patternName $ patternFromInput i) <> (" " <> maybe mempty (P.text . uncurry3 RemoteRepo.printNamespace) ns) <> " " <> P.shown p' diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index dd8babf80f..2ad7d77963 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -11,7 +11,6 @@ import Control.Exception (finally, catch, AsyncException(UserInterrupt), asyncEx import Control.Monad.State (runStateT) import Data.Configurator.Types (Config) import Data.IORef -import Data.Tuple.Extra (uncurry3) import Prelude hiding (readFile, writeFile) import System.IO.Error (isDoesNotExistError) import Unison.Codebase.Branch (Branch) @@ -21,14 +20,13 @@ import qualified Unison.Server.CodebaseServer as Server import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import Unison.Codebase.Editor.Command (LoadSourceResult(..)) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, printNamespace) import Unison.Codebase (Codebase) import Unison.CommandLine import Unison.PrettyTerminal import Unison.CommandLine.InputPattern (ArgumentType (suggestions), InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) -import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered, shortenDirectory) -import Unison.Parser (Ann) +import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) +import Unison.Parser.Ann (Ann) import Unison.Symbol (Symbol) import qualified Control.Concurrent.Async as Async import qualified Data.Map as Map @@ -42,6 +40,7 @@ import qualified Unison.Codebase as Codebase import qualified Unison.CommandLine.InputPattern as IP import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as Q +import qualified Unison.CommandLine.Welcome as Welcome import Text.Regex.TDFA import Control.Lens (view) import Control.Error (rightMay) @@ -104,77 +103,25 @@ getUserInput patterns codebase branch currentPath numberedArgs = Line.runInputT pure $ suggestions argType word codebase branch currentPath _ -> pure [] -asciiartUnison :: P.Pretty P.ColorText -asciiartUnison = - P.red " _____" - <> P.hiYellow " _ " - <> P.newline - <> P.red "| | |" - <> P.hiRed "___" - <> P.hiYellow "|_|" - <> P.hiGreen "___ " - <> P.cyan "___ " - <> P.purple "___ " - <> P.newline - <> P.red "| | | " - <> P.hiYellow "| |" - <> P.hiGreen "_ -" - <> P.cyan "| . |" - <> P.purple " |" - <> P.newline - <> P.red "|_____|" - <> P.hiRed "_|_" - <> P.hiYellow "|_|" - <> P.hiGreen "___" - <> P.cyan "|___|" - <> P.purple "_|_|" - -welcomeMessage :: FilePath -> String -> P.Pretty P.ColorText -welcomeMessage dir version = - asciiartUnison - <> P.newline - <> P.newline - <> P.linesSpaced - [ P.wrap "Welcome to Unison!" - , P.wrap ("You are running version: " <> P.string version) - , P.wrap - ( "I'm currently watching for changes to .u files under " - <> (P.group . P.blue $ fromString dir) - ) - , P.wrap ("Type " <> P.hiBlue "help" <> " to get help. 😎") - ] - -hintFreshCodebase :: ReadRemoteNamespace -> P.Pretty P.ColorText -hintFreshCodebase ns = - P.wrap $ "Enter " - <> (P.hiBlue . P.group) - ("pull " <> P.text (uncurry3 printNamespace ns) <> " .base") - <> "to set up the default base library. πŸ—" - main :: FilePath - -> Maybe ReadRemoteNamespace + -> Welcome.Welcome -> Path.Absolute -> (Config, IO ()) -> [Either Event Input] -> Runtime.Runtime Symbol -> Codebase IO Symbol Ann - -> String -> Maybe Server.BaseUrl -> IO () -main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do - dir' <- shortenDirectory dir +main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - putPrettyLn $ case defaultBaseLib of - Just ns | Branch.isOne root -> - welcomeMessage dir' version <> P.newline <> P.newline <> hintFreshCodebase ns - _ -> welcomeMessage dir' version eventQueue <- Q.newIO + welcomeEvents <-Welcome.run codebase welcome do -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef initialInputs + initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 9def8de13e..5c015a680e 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -38,6 +38,7 @@ import System.Directory ( canonicalizePath ) import qualified Unison.ABT as ABT import qualified Unison.UnisonFile as UF +import Unison.Codebase.Type (GitError(GitSqliteCodebaseError, GitProtocolError, GitCodebaseError)) import Unison.Codebase.GitError import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Patch as Patch @@ -73,8 +74,10 @@ import Unison.NamePrinter (prettyHashQualified, import Unison.Names2 (Names'(..), Names0) import qualified Unison.Names2 as Names import qualified Unison.Names3 as Names -import Unison.Parser (Ann, startingLine) +import Unison.Parser.Ann (Ann, startingLine) import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Codebase.Runtime as Runtime import Unison.PrintError ( prettyParseError , printNoteWithSource @@ -101,7 +104,6 @@ import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import Unison.Codebase.Editor.DisplayObject (DisplayObject(MissingObject, BuiltinObject, UserObject)) -import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Hash as Hash import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo @@ -112,6 +114,10 @@ import qualified Unison.ShortHash as SH import Unison.LabeledDependency as LD import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo) import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) +import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError(UnrecognizedSchemaVersion, GitCouldntParseRootBranchHash)) +import qualified Unison.Referent' as Referent +import qualified Unison.WatchKind as WK +import qualified Unison.Codebase.Editor.Input as Input type Pretty = P.Pretty P.ColorText @@ -251,6 +257,8 @@ prettyRemoteNamespace = notifyUser :: forall v . Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of Success -> pure $ P.bold "Done." + PrintMessage pretty -> do + pure pretty BadRootBranch e -> case e of Codebase.NoRootBranch -> pure . P.fatalCallout $ "I couldn't find the codebase root!" @@ -672,75 +680,75 @@ notifyUser dir o = case o of TodoOutput names todo -> pure (todoOutput names todo) GitError input e -> pure $ case e of - CouldntOpenCodebase repo localPath -> P.wrap $ "I couldn't open the repository at" - <> prettyReadRepo repo <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap - $ "I don't know how to interpret schema version " <> P.shown v - <> "in the repository at" <> prettyReadRepo repo - <> "in the cache directory at" <> P.backticked' (P.string localPath) "." - CouldntParseRootBranch repo s -> P.wrap $ "I couldn't parse the string" - <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadRepo repo <> ".") - CouldntLoadSyncedBranch h -> P.wrap $ "I just finished importing the branch" - <> P.red (P.shown h) <> "but now I can't find it." - NoGit -> P.wrap $ - "I couldn't find git. Make sure it's installed and on your path." - CloneException repo msg -> P.wrap $ - "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" - <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg - PushNoOp repo -> P.wrap $ - "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." - PushException repo msg -> P.wrap $ - "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" - <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg - UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" - <> P.backticked (P.text uri) <> "already exists at" - <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" - <> "be a git repository, so I'm not sure what to do next. Delete it?" - UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" - <> P.backticked (P.text uri) <> "into a cache directory at" - <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" - <> "result as a git repository, so I'm not sure what to do next." - PushDestinationHasNewStuff repo -> - P.callout "⏸" . P.lines $ [ - P.wrap $ "The repository at" <> prettyWriteRepo repo - <> "has some changes I don't know about.", - "", - P.wrap $ "If you want to " <> push <> "you can do:", "", - P.indentN 2 pull, "", - P.wrap $ - "to merge these changes locally," <> - "then try your" <> push <> "again." - ] - where - push = P.group . P.backticked . P.string . IP1.patternName $ IP.patternFromInput input - pull = P.group . P.backticked $ IP.inputStringFromInput input - CouldntLoadRootBranch repo hash -> P.wrap - $ "I couldn't load the designated root hash" - <> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")") - <> "from the repository at" <> prettyReadRepo repo - NoRemoteNamespaceWithHash repo sbh -> P.wrap - $ "The repository at" <> prettyReadRepo repo - <> "doesn't contain a namespace with the hash prefix" - <> (P.blue . P.text . SBH.toText) sbh - RemoteNamespaceHashAmbiguous repo sbh hashes -> P.lines [ - P.wrap $ "The namespace hash" <> prettySBH sbh - <> "at" <> prettyReadRepo repo - <> "is ambiguous." - <> "Did you mean one of these hashes?", - "", - P.indentN 2 $ P.lines - (prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2) - <$> Set.toList hashes), - "", - P.wrap "Try again with a few more hash characters to disambiguate." - ] - SomeOtherError msg -> P.callout "β€Ό" . P.lines $ [ - P.wrap "I ran into an error:", "", - P.indentN 2 (P.string msg), "", - P.wrap $ "Check the logging messages above for more info." - ] + GitSqliteCodebaseError e -> case e of + UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap + $ "I don't know how to interpret schema version " <> P.shown v + <> "in the repository at" <> prettyReadRepo repo + <> "in the cache directory at" <> P.backticked' (P.string localPath) "." + GitCouldntParseRootBranchHash repo s -> P.wrap $ "I couldn't parse the string" + <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" + <> P.group (prettyReadRepo repo <> ".") + GitProtocolError e -> case e of + NoGit -> P.wrap $ + "I couldn't find git. Make sure it's installed and on your path." + CleanupError e -> P.wrap $ + "I encountered an exception while trying to clean up a git cache directory:" + <> P.group (P.shown e) + CloneException repo msg -> P.wrap $ + "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" + <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg + PushNoOp repo -> P.wrap $ + "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." + PushException repo msg -> P.wrap $ + "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" + <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg + UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" + <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) <> "already exists at" + <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" + <> "be a git repository, so I'm not sure what to do next. Delete it?" + UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" + <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) <> "into a cache directory at" + <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" + <> "result as a git repository, so I'm not sure what to do next." + PushDestinationHasNewStuff repo -> + P.callout "⏸" . P.lines $ [ + P.wrap $ "The repository at" <> prettyWriteRepo repo + <> "has some changes I don't know about.", + "", + P.wrap $ "If you want to " <> push <> "you can do:", "", + P.indentN 2 pull, "", + P.wrap $ + "to merge these changes locally," <> + "then try your" <> push <> "again." + ] + where + push = P.group . P.backticked . P.string . IP1.patternName $ IP.patternFromInput input + pull = P.group . P.backticked $ IP.inputStringFromInput input + GitCodebaseError e -> case e of + CouldntLoadRootBranch repo hash -> P.wrap + $ "I couldn't load the designated root hash" + <> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")") + <> "from the repository at" <> prettyReadRepo repo + CouldntLoadSyncedBranch ns h -> P.wrap + $ "I just finished importing the branch" <> P.red (P.shown h) + <> "from" <> P.red (prettyRemoteNamespace ns) + <> "but now I can't find it." + NoRemoteNamespaceWithHash repo sbh -> P.wrap + $ "The repository at" <> prettyReadRepo repo + <> "doesn't contain a namespace with the hash prefix" + <> (P.blue . P.text . SBH.toText) sbh + RemoteNamespaceHashAmbiguous repo sbh hashes -> P.lines [ + P.wrap $ "The namespace hash" <> prettySBH sbh + <> "at" <> prettyReadRepo repo + <> "is ambiguous." + <> "Did you mean one of these hashes?", + "", + P.indentN 2 $ P.lines + (prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2) + <$> Set.toList hashes), + "", + P.wrap "Try again with a few more hash characters to disambiguate." + ] ListEdits patch ppe -> do let types = Patch._typeEdits patch @@ -1144,7 +1152,7 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp BuiltinObject _ -> builtin n UserObject decl -> case decl of Left d -> DeclPrinter.prettyEffectDecl (ppeBody r) r n d - Right d -> DeclPrinter.prettyDataDecl (ppeBody r) r n d + Right d -> DeclPrinter.prettyDataDecl (PPE.declarationPPEDecl ppe0 r) r n d builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in." missing n r = P.wrap ( "-- The name " <> prettyHashQualified n <> " is assigned to the " @@ -1883,7 +1891,7 @@ watchPrinter => Text -> PPE.PrettyPrintEnv -> Ann - -> UF.WatchKind + -> WK.WatchKind -> Term v () -> Runtime.IsCacheHit -> Pretty @@ -1914,7 +1922,7 @@ watchPrinter src ppe ann kind term isHit = P.lines [ fromString (show lineNum) <> " | " <> P.text line , case (kind, term) of - (UF.TestWatch, Term.List' tests) -> foldMap renderTest tests + (WK.TestWatch, Term.List' tests) -> foldMap renderTest tests _ -> P.lines [ fromString (replicate lineNumWidth ' ') <> fromString extra diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs new file mode 100644 index 0000000000..ae67dce915 --- /dev/null +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +module Unison.CommandLine.Welcome where + +import Unison.Prelude +import Unison.Codebase (Codebase) +import qualified Unison.Codebase as Codebase +import Prelude hiding (readFile, writeFile) +import qualified Unison.Util.Pretty as P +import System.Random (randomRIO) +import Unison.Codebase.Path (Path) + +import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.SyncMode as SyncMode +import Unison.Codebase.Editor.Input +import Data.Sequence (singleton) +import Unison.NameSegment (NameSegment(NameSegment)) + +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import qualified Unison.Codebase.Verbosity as Verbosity + +data Welcome = Welcome + { onboarding :: Onboarding -- Onboarding States + , downloadBase :: DownloadBase + , watchDir :: FilePath + , unisonVersion :: String + } + +data DownloadBase + = DownloadBase ReadRemoteNamespace | DontDownloadBase + +-- Previously Created is different from Previously Onboarded because a user can +-- 1.) create a new codebase +-- 2.) decide not to go through the onboarding flow until later and exit +-- 3.) then reopen their blank codebase +data CodebaseInitStatus + = NewlyCreatedCodebase -- Can transition to [Base, Author, Finished] + | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. + +data Onboarding + = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] + | DownloadingBase ReadRemoteNamespace -- Can transition to [Author, Finished] + | Author -- Can transition to [Finished] + -- End States + | Finished + | PreviouslyOnboarded + +welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> String -> Welcome +welcome initStatus downloadBase filePath unisonVersion = + Welcome (Init initStatus) downloadBase filePath unisonVersion + +pullBase :: ReadRemoteNamespace -> Either Event Input +pullBase _ns = let + seg = NameSegment "base" + rootPath = Path.Path { Path.toSeq = singleton seg } + abs = Path.Absolute {Path.unabsolute = rootPath} + pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent + in Right pullRemote + +run :: Codebase IO v a -> Welcome -> IO [Either Event Input] +run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do + go onboarding [] + where + go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] + go onboarding acc = + case onboarding of + Init NewlyCreatedCodebase -> do + determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) + where + headerMsg = toInput (header version) + Init PreviouslyCreatedCodebase -> do + go PreviouslyOnboarded (headerMsg : acc) + where + headerMsg = toInput (header version) + DownloadingBase ns@(_, _, path) -> + go Author ([pullBaseInput, downloadMsg] ++ acc) + where + downloadMsg = Right $ CreateMessage (downloading path) + pullBaseInput = pullBase ns + Author -> + go Finished (authorMsg : acc) + where + authorMsg = toInput authorSuggestion + -- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards + Finished -> do + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) + PreviouslyOnboarded -> do + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) + +toInput :: P.Pretty P.ColorText -> Either Event Input +toInput pretty = + Right $ CreateMessage pretty + +determineFirstStep :: DownloadBase -> Codebase IO v a -> IO Onboarding +determineFirstStep downloadBase codebase = do + isBlankCodebase <- Codebase.isBlank codebase + case downloadBase of + DownloadBase ns | isBlankCodebase -> + pure $ DownloadingBase ns + _ -> + pure PreviouslyOnboarded + +asciiartUnison :: P.Pretty P.ColorText +asciiartUnison = + P.red " _____" + <> P.hiYellow " _ " + <> P.newline + <> P.red "| | |" + <> P.hiRed "___" + <> P.hiYellow "|_|" + <> P.hiGreen "___ " + <> P.cyan "___ " + <> P.purple "___ " + <> P.newline + <> P.red "| | | " + <> P.hiYellow "| |" + <> P.hiGreen "_ -" + <> P.cyan "| . |" + <> P.purple " |" + <> P.newline + <> P.red "|_____|" + <> P.hiRed "_|_" + <> P.hiYellow "|_|" + <> P.hiGreen "___" + <> P.cyan "|___|" + <> P.purple "_|_|" + + +downloading :: Path -> P.Pretty P.ColorText +downloading path = + P.lines + [ P.group (P.wrap "🐣 Since this is a fresh codebase, let me download the base library for you." <> P.newline ), + P.wrap + ("πŸ• Downloading" + <> P.blue (P.string (show path)) + <> "of the" + <> P.bold "base library" + <> "into" + <> P.group (P.blue ".base" <> ", this may take a minute...") + ) + ] + +header :: String -> P.Pretty P.ColorText +header version = + asciiartUnison + <> P.newline + <> P.newline + <> P.linesSpaced + [ P.wrap "πŸ‘‹ Welcome to Unison!", + P.wrap ("You are running version: " <> P.bold (P.string version)) + ] + +authorSuggestion :: P.Pretty P.ColorText +authorSuggestion = + P.newline <> + P.lines [ P.wrap "πŸ“œ πŸͺΆ You might want to set up your author information next.", + P.wrap "Type" <> P.hiBlue " create.author" <> " to create an author for this codebase", + P.group( P.newline <> P.wrap "Read about how to link your author to your code at"), + P.wrap $ P.blue "https://www.unisonweb.org/docs/configuration/#setting-default-metadata-like-license-and-author" + ] + +getStarted :: FilePath -> IO (P.Pretty P.ColorText) +getStarted dir = do + earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2) + + pure $ P.linesSpaced [ + P.wrap "Get started:", + P.indentN 2 $ P.column2 + [ ("πŸ“–", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help " <> " to view help for one command"), + ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), + ("πŸ“š", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), + (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), + ("πŸ‘€", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir)) + ] + ] \ No newline at end of file diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index e0d98f1f24..901f4bf5dd 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -13,18 +13,18 @@ import Unison.DataDeclaration ( DataDeclaration ) import qualified Unison.DataDeclaration as DD import qualified Unison.ConstructorType as CT +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.HashQualified ( HashQualified ) import qualified Unison.HashQualified as HQ import qualified Unison.Name as Name import Unison.Name ( Name ) import Unison.NamePrinter ( styleHashQualified'' ) import Unison.PrettyPrintEnv ( PrettyPrintEnv ) +import Unison.PrettyPrintEnvDecl ( PrettyPrintEnvDecl(..) ) import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import Unison.Reference ( Reference(DerivedId) ) import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText ( SyntaxText ) -import qualified Unison.Term as Term import qualified Unison.Type as Type import qualified Unison.TypePrinter as TypePrinter import Unison.Util.Pretty ( Pretty ) @@ -32,15 +32,17 @@ import qualified Unison.Util.Pretty as P import Unison.Var ( Var ) import qualified Unison.Var as Var +type SyntaxText = S.SyntaxText' Reference + prettyDecl :: Var v - => PrettyPrintEnv + => PrettyPrintEnvDecl -> Reference -> HashQualified Name -> DD.Decl v a -> Pretty SyntaxText -prettyDecl ppe r hq d = case d of - Left e -> prettyEffectDecl ppe r hq e +prettyDecl ppe@(PrettyPrintEnvDecl unsuffixifiedPPE _) r hq d = case d of + Left e -> prettyEffectDecl unsuffixifiedPPE r hq e Right dd -> prettyDataDecl ppe r hq dd prettyEffectDecl @@ -87,12 +89,12 @@ prettyPattern env ctorType ref namespace cid = styleHashQualified'' prettyDataDecl :: Var v - => PrettyPrintEnv + => PrettyPrintEnvDecl -> Reference -> HashQualified Name -> DataDeclaration v a -> Pretty SyntaxText -prettyDataDecl env r name dd = +prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd = (header <>) . P.sep (fmt S.DelimiterChar (" | " `P.orElse` "\n | ")) $ constructor <$> zip [0 ..] (DD.constructors' dd) @@ -100,16 +102,16 @@ prettyDataDecl env r name dd = constructor (n, (_, _, (Type.ForallsNamed' _ t))) = constructor' n t constructor (n, (_, _, t) ) = constructor' n t constructor' n t = case Type.unArrows t of - Nothing -> prettyPattern env CT.Data r name n - Just ts -> case fieldNames env r name dd of - Nothing -> P.group . P.hang' (prettyPattern env CT.Data r name n) " " - $ P.spaced (TypePrinter.prettyRaw env Map.empty 10 <$> init ts) + Nothing -> prettyPattern suffixifiedPPE CT.Data r name n + Just ts -> case fieldNames unsuffixifiedPPE r name dd of + Nothing -> P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data r name n) " " + $ P.spaced (TypePrinter.prettyRaw suffixifiedPPE Map.empty 10 <$> init ts) Just fs -> P.group $ (fmt S.DelimiterChar "{ ") <> P.sep ((fmt S.DelimiterChar ",") <> " " `P.orElse` "\n ") (field <$> zip fs (init ts)) <> (fmt S.DelimiterChar " }") field (fname, typ) = P.group $ styleHashQualified'' (fmt (S.Reference r)) fname <> - (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw env Map.empty (-1) typ + (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw suffixifiedPPE Map.empty (-1) typ header = prettyDataHeader name dd <> (fmt S.DelimiterChar (" = " `P.orElse` "\n = ")) -- Comes up with field names for a data declaration which has the form of a @@ -137,14 +139,13 @@ fieldNames env r name dd = case DD.constructors dd of vars :: [v] vars = [ Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0..Type.arity typ - 1]] accessors = DD.generateRecordAccessors (map (,()) vars) (HQ.toVar name) r - hashes = Term.hashComponents (Map.fromList accessors) + hashes = Hashing.hashTermComponents (Map.fromList accessors) names = [ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r) | r <- fst <$> Map.elems hashes ] fieldNames = Map.fromList [ (r, f) | (r, n) <- names , typename <- pure (HQ.toString name) , typename `isPrefixOf` n - -- drop the typename and the following '.' , rest <- pure $ drop (length typename + 1) n , (f, rest) <- pure $ span (/= '.') rest , rest `elem` ["",".set",".modify"] ] @@ -157,7 +158,7 @@ fieldNames env r name dd = case DD.constructors dd of _ -> Nothing prettyModifier :: DD.Modifier -> Pretty SyntaxText -prettyModifier DD.Structural = mempty +prettyModifier DD.Structural = fmt S.DataTypeModifier "structural" prettyModifier (DD.Unique _uid) = fmt S.DataTypeModifier "unique" -- <> ("[" <> P.text uid <> "] ") diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index e81a102f08..e0ff8f554c 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -1,5 +1,6 @@ {-# Language DeriveTraversable #-} {-# Language OverloadedStrings #-} +{-# Language ViewPatterns #-} module Unison.FileParser where @@ -8,25 +9,31 @@ import Unison.Prelude import qualified Unison.ABT as ABT import Control.Lens import Control.Monad.Reader (local, asks) +import Data.List.Extra (nubOrd) import qualified Data.Map as Map +import qualified Data.Set as Set import Prelude hiding (readFile) import qualified Text.Megaparsec as P import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) import qualified Unison.DataDeclaration as DD import qualified Unison.Lexer as L import Unison.Parser +import Unison.Parser.Ann (Ann) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermParser as TermParser import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.TypeParser as TypeParser -import Unison.UnisonFile (UnisonFile(..), environmentFor) -import qualified Unison.UnisonFile as UF +import Unison.UnisonFile (UnisonFile(..)) +import qualified Unison.UnisonFile.Env as UF +import Unison.UnisonFile.Names (environmentFor) import qualified Unison.Util.List as List import Unison.Var (Var) import qualified Unison.Var as Var +import qualified Unison.WatchKind as UF import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name resolutionFailures :: Ord v => [Names.ResolutionFailure v Ann] -> P v x @@ -69,7 +76,7 @@ file = do -- suffixified local term bindings shadow any same-named thing from the outer codebase scope -- example: `foo.bar` in local file scope will shadow `foo.bar` and `bar` in codebase scope let (curNames, resolveLocals) = - ( Names.shadowSuffixedTerms0 locals (Names.currentNames names) + ( Names.shadowTerms0 locals (Names.currentNames names) , resolveLocals ) where -- All locally declared term variables, running example: @@ -88,8 +95,9 @@ file = do -- suffix, but `bob` is. `foo.alice` and `bob.alice` are both unique suffixes but -- they map to themselves, so we ignore them. In our example, we'll just be left with -- [(bob, Term.var() zonk.bob)] - replacements = [ (Name.toVar n, Term.var() v') | (n,[v']) <- Map.toList varsBySuffix - , Name.toVar n /= v' ] + replacements = [ (Name.toVar n, Term.var() v') + | (n, nubOrd -> [v']) <- Map.toList varsBySuffix + , Name.toVar n /= v' ] locals = Map.keys varsBySuffix -- This will perform the actual variable replacements for suffixes -- that uniquely identify definitions in the file. It will avoid @@ -97,10 +105,12 @@ file = do -- `bob -> bob * 42`, `bob` will correctly refer to the lambda parameter. -- and not the `zonk.bob` declared in the file. resolveLocals = ABT.substsInheritAnnotation replacements - terms <- case List.validate (traverse $ Term.bindSomeNames curNames . resolveLocals) terms of + let bindNames = Term.bindSomeNames avoid curNames . resolveLocals + where avoid = Set.fromList (stanzas0 >>= getVars) + terms <- case List.validate (traverse bindNames) terms of Left es -> resolutionFailures (toList es) Right terms -> pure terms - watches <- case List.validate (traverse . traverse $ Term.bindSomeNames curNames . resolveLocals) watches of + watches <- case List.validate (traverse . traverse $ bindNames) watches of Left es -> resolutionFailures (toList es) Right ws -> pure ws let toPair (tok, _) = (L.payload tok, ann tok) @@ -212,18 +222,22 @@ declarations = do [ (v, DD.annotation <$> ds) | (v, ds) <- Map.toList mdsBad ] <> [ (v, DD.annotation . DD.toDataDecl <$> es) | (v, es) <- Map.toList mesBad ] -modifier :: Var v => P v (L.Token DD.Modifier) +-- unique[someguid] type Blah = ... +modifier :: Var v => P v (Maybe (L.Token DD.Modifier)) modifier = do - o <- optional (openBlockWith "unique") - case o of - Nothing -> fmap (const DD.Structural) <$> P.lookAhead anyToken - Just tok -> do + optional (unique <|> structural) + where + unique = do + tok <- openBlockWith "unique" uid <- do - o <- optional (reserved "[" *> wordyIdString <* reserved "]") + o <- optional (openBlockWith "[" *> wordyIdString <* closeBlock) case o of Nothing -> uniqueName 32 Just uid -> pure (fromString . L.payload $ uid) pure (DD.Unique uid <$ tok) + structural = do + tok <- openBlockWith "structural" + pure (DD.Structural <$ tok) declaration :: Var v => P v (Either (v, DataDeclaration v Ann, Accessors v) @@ -235,10 +249,10 @@ declaration = do dataDeclaration :: forall v . Var v - => L.Token DD.Modifier + => Maybe (L.Token DD.Modifier) -> P v (v, DataDeclaration v Ann, Accessors v) dataDeclaration mod = do - _ <- fmap void (reserved "type") <|> openBlockWith "type" + keywordTok <- fmap void (reserved "type") <|> openBlockWith "type" (name, typeArgs) <- (,) <$> TermParser.verifyRelativeVarName prefixDefinitionName <*> many (TermParser.verifyRelativeVarName prefixDefinitionName) @@ -274,16 +288,19 @@ dataDeclaration mod = do -- otherwise ann of name closingAnn :: Ann closingAnn = last (ann eq : ((\(_,_,t) -> ann t) <$> constructors)) - pure (L.payload name, - DD.mkDataDecl' (L.payload mod) (ann mod <> closingAnn) typeArgVs constructors, - accessors) + case mod of + Nothing -> P.customFailure $ MissingTypeModifier ("type" <$ keywordTok) name + Just mod' -> + pure (L.payload name, + DD.mkDataDecl' (L.payload mod') (ann mod' <> closingAnn) typeArgVs constructors, + accessors) effectDeclaration - :: Var v => L.Token DD.Modifier -> P v (v, EffectDeclaration v Ann) + :: Var v => Maybe (L.Token DD.Modifier) -> P v (v, EffectDeclaration v Ann) effectDeclaration mod = do - _ <- fmap void (reserved "ability") <|> openBlockWith "ability" - name <- TermParser.verifyRelativeVarName prefixDefinitionName - typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) + keywordTok <- fmap void (reserved "ability") <|> openBlockWith "ability" + name <- TermParser.verifyRelativeVarName prefixDefinitionName + typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) let typeArgVs = L.payload <$> typeArgs blockStart <- openBlockWith "where" constructors <- sepBy semi (constructor typeArgs name) @@ -291,13 +308,17 @@ effectDeclaration mod = do _ <- closeBlock <* closeBlock let closingAnn = last $ ann blockStart : ((\(_, _, t) -> ann t) <$> constructors) - pure - ( L.payload name - , DD.mkEffectDecl' (L.payload mod) - (ann mod <> closingAnn) - typeArgVs - constructors - ) + + case mod of + Nothing -> P.customFailure $ MissingTypeModifier ("ability" <$ keywordTok) name + Just mod' -> + pure + ( L.payload name + , DD.mkEffectDecl' (L.payload mod') + (ann mod' <> closingAnn) + typeArgVs + constructors + ) where constructor :: Var v => [L.Token v] -> L.Token v -> P v (Ann, v, Type v Ann) diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index 155d4d5dc9..394c92db8b 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -21,7 +21,7 @@ import qualified Unison.ABT as ABT import qualified Unison.Blank as Blank import qualified Unison.Name as Name import qualified Unison.Names3 as Names -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import qualified Unison.Parsers as Parsers import qualified Unison.Referent as Referent import Unison.Reference (Reference) @@ -33,6 +33,7 @@ import qualified Unison.Typechecker as Typechecker import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.Typechecker.Context as Context import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF import qualified Unison.Util.List as List import qualified Unison.Util.Relation as Rel import Unison.Var (Var) diff --git a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs new file mode 100644 index 0000000000..3b7efb671c --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Convert + ( HashingInfo(..), + ResolutionFailure(..), + ResolutionResult, + assumeSingletonComponent, + hashDecls, + hashClosedTerm, + hashTermComponents, + hashTypeComponents, + typeToReference, + typeToReferenceMentions, + unsafe, + ) +where + +import Control.Lens (over, _3) +import qualified Control.Lens as Lens +import Control.Monad.Validate (Validate) +import qualified Control.Monad.Validate as Validate +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Unison.ABT as ABT +import qualified Unison.DataDeclaration as Memory.DD +import Unison.Hash (Hash) +import qualified Unison.Hashing.V1.DataDeclaration as Hashing.DD +import qualified Unison.Hashing.V1.Pattern as Hashing.Pattern +import qualified Unison.Hashing.V1.Reference as Hashing.Reference +import qualified Unison.Hashing.V1.Referent as Hashing.Referent +import qualified Unison.Hashing.V1.Term as Hashing.Term +import qualified Unison.Hashing.V1.Type as Hashing.Type +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Pattern as Memory.Pattern +import qualified Unison.Reference as Memory.Reference +import qualified Unison.Referent as Memory.Referent +import qualified Unison.Term as Memory.Term +import qualified Unison.Type as Memory.Type +import Unison.Var (Var) +import qualified Data.Set as Set + +data ResolutionFailure v a + = TermResolutionFailure v a (Set Memory.Referent.Referent) + | TypeResolutionFailure v a (Set Memory.Reference.Reference) + | CycleResolutionFailure Hash + deriving (Eq, Ord, Show) + +type ResolutionResult v a r = Validate (Seq (ResolutionFailure v a)) r + +newtype HashingInfo = HashingInfo (Hash -> Maybe Hashing.Reference.Size) + +convertResolutionResult :: Names.ResolutionResult v a r -> ResolutionResult v a r +convertResolutionResult = \case + Left e -> Validate.refute (fmap f e) + Right a -> pure a + where + f = \case + Names.TermResolutionFailure v a rs -> TermResolutionFailure v a rs + Names.TypeResolutionFailure v a rs -> TypeResolutionFailure v a rs + +typeToReference :: + Var v => + HashingInfo -> + Memory.Type.Type v a -> + Validate (Seq Hash) Memory.Reference.Reference +typeToReference f memType = + h2mReference . Hashing.Type.toReference <$> m2hType f memType + +typeToReferenceMentions :: + Var v => + HashingInfo -> + Memory.Type.Type v a -> + Validate (Seq Hash) (Set Memory.Reference.Reference) +typeToReferenceMentions f memType = + Set.map h2mReference . Hashing.Type.toReferenceMentions <$> m2hType f memType + +hashTypeComponents :: + Var v => HashingInfo -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) +hashTypeComponents f memTypes = do + hashingTypes <- traverse (m2hType f) memTypes + let hashingResult = Hashing.Type.hashComponents hashingTypes + pure $ fmap h2mTypeResult hashingResult + where + h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) + h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp) + +assumeSingletonComponent :: HashingInfo +assumeSingletonComponent = HashingInfo (\_ -> Just 1) + +unsafe :: Validate (Seq Hash) a -> a +unsafe v = case Validate.runValidate v of + Right a -> a + Left missing -> + error $ "unison.hashing.v1.unsafe: missing sizes for the following components: " ++ show missing + +hashTermComponents :: Var v => HashingInfo -> Map v (Memory.Term.Term v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Term.Term v a)) +hashTermComponents f memTerms = do + hashingTerms <- traverse (m2hTerm f) memTerms + let hashingResult = Hashing.Term.hashComponents hashingTerms + pure $ fmap h2mTermResult hashingResult + where + h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a) + h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm) + +hashClosedTerm :: Var v => Memory.Term.Term v a -> Memory.Reference.Id +hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . unsafe . m2hTerm assumeSingletonComponent + +m2hTerm :: Ord v => HashingInfo -> Memory.Term.Term v a -> Validate (Seq Hash) (Hashing.Term.Term v a) +m2hTerm f = ABT.transformM \case + Memory.Term.Int i -> pure $ Hashing.Term.Int i + Memory.Term.Nat n -> pure $ Hashing.Term.Nat n + Memory.Term.Float d -> pure $ Hashing.Term.Float d + Memory.Term.Boolean b -> pure $ Hashing.Term.Boolean b + Memory.Term.Text t -> pure $ Hashing.Term.Text t + Memory.Term.Char c -> pure $ Hashing.Term.Char c + Memory.Term.Blank b -> pure $ Hashing.Term.Blank b + Memory.Term.Ref r -> Hashing.Term.Ref <$> m2hReference f r + Memory.Term.Constructor r i -> Hashing.Term.Constructor <$> m2hReference f r <*> pure i + Memory.Term.Request r i -> Hashing.Term.Request <$> m2hReference f r <*> pure i + Memory.Term.Handle x y -> pure $ Hashing.Term.Handle x y + Memory.Term.App f x -> pure $ Hashing.Term.App f x + Memory.Term.Ann e t -> Hashing.Term.Ann e <$> m2hType f t + Memory.Term.List as -> pure $ Hashing.Term.List as + Memory.Term.If c t f -> pure $ Hashing.Term.If c t f + Memory.Term.And p q -> pure $ Hashing.Term.And p q + Memory.Term.Or p q -> pure $ Hashing.Term.Or p q + Memory.Term.Lam a -> pure $ Hashing.Term.Lam a + Memory.Term.LetRec isTop bs body -> pure $ Hashing.Term.LetRec isTop bs body + Memory.Term.Let isTop b body -> pure $ Hashing.Term.Let isTop b body + Memory.Term.Match scr cases -> Hashing.Term.Match scr <$> traverse (m2hMatchCase f) cases + Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent f r + Memory.Term.TypeLink r -> Hashing.Term.TypeLink <$> m2hReference f r + +m2hMatchCase :: HashingInfo -> Memory.Term.MatchCase a a1 -> Validate (Seq Hash) (Hashing.Term.MatchCase a a1) +m2hMatchCase f (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase <$> m2hPattern f pat <*> pure m_a1 <*> pure a1 + +m2hPattern :: HashingInfo -> Memory.Pattern.Pattern a -> Validate (Seq Hash) (Hashing.Pattern.Pattern a) +m2hPattern f = \case + Memory.Pattern.Unbound loc -> pure $ Hashing.Pattern.Unbound loc + Memory.Pattern.Var loc -> pure $ Hashing.Pattern.Var loc + Memory.Pattern.Boolean loc b -> pure $ Hashing.Pattern.Boolean loc b + Memory.Pattern.Int loc i -> pure $ Hashing.Pattern.Int loc i + Memory.Pattern.Nat loc n -> pure $ Hashing.Pattern.Nat loc n + Memory.Pattern.Float loc f -> pure $ Hashing.Pattern.Float loc f + Memory.Pattern.Text loc t -> pure $ Hashing.Pattern.Text loc t + Memory.Pattern.Char loc c -> pure $ Hashing.Pattern.Char loc c + Memory.Pattern.Constructor loc r i ps -> Hashing.Pattern.Constructor loc <$> m2hReference f r <*> pure i <*> traverse (m2hPattern f) ps + Memory.Pattern.As loc p -> Hashing.Pattern.As loc <$> m2hPattern f p + Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc <$> m2hPattern f p + Memory.Pattern.EffectBind loc r i ps k -> Hashing.Pattern.EffectBind loc <$> m2hReference f r <*> pure i <*> traverse (m2hPattern f) ps <*> m2hPattern f k + Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc <$> traverse (m2hPattern f) ps + Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc <$> m2hPattern f l <*> pure (m2hSequenceOp op) <*> m2hPattern f r + +m2hSequenceOp :: Memory.Pattern.SeqOp -> Hashing.Pattern.SeqOp +m2hSequenceOp = \case + Memory.Pattern.Cons -> Hashing.Pattern.Cons + Memory.Pattern.Snoc -> Hashing.Pattern.Snoc + Memory.Pattern.Concat -> Hashing.Pattern.Concat + +m2hReferent :: HashingInfo -> Memory.Referent.Referent -> Validate (Seq Hash) Hashing.Referent.Referent +m2hReferent f = \case + Memory.Referent.Ref ref -> Hashing.Referent.Ref <$> m2hReference f ref + Memory.Referent.Con ref n ct -> Hashing.Referent.Con <$> m2hReference f ref <*> pure n <*> pure ct + +h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a +h2mTerm = ABT.transform \case + Hashing.Term.Int i -> Memory.Term.Int i + Hashing.Term.Nat n -> Memory.Term.Nat n + Hashing.Term.Float d -> Memory.Term.Float d + Hashing.Term.Boolean b -> Memory.Term.Boolean b + Hashing.Term.Text t -> Memory.Term.Text t + Hashing.Term.Char c -> Memory.Term.Char c + Hashing.Term.Blank b -> Memory.Term.Blank b + Hashing.Term.Ref r -> Memory.Term.Ref (h2mReference r) + Hashing.Term.Constructor r i -> Memory.Term.Constructor (h2mReference r) i + Hashing.Term.Request r i -> Memory.Term.Request (h2mReference r) i + Hashing.Term.Handle x y -> Memory.Term.Handle x y + Hashing.Term.App f x -> Memory.Term.App f x + Hashing.Term.Ann e t -> Memory.Term.Ann e (h2mType t) + Hashing.Term.List as -> Memory.Term.List as + Hashing.Term.If c t f -> Memory.Term.If c t f + Hashing.Term.And p q -> Memory.Term.And p q + Hashing.Term.Or p q -> Memory.Term.Or p q + Hashing.Term.Lam a -> Memory.Term.Lam a + Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body + Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body + Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases) + Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent r) + Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r) + +h2mMatchCase :: Hashing.Term.MatchCase a b -> Memory.Term.MatchCase a b +h2mMatchCase (Hashing.Term.MatchCase pat m_b b) = Memory.Term.MatchCase (h2mPattern pat) m_b b + +h2mPattern :: Hashing.Pattern.Pattern a -> Memory.Pattern.Pattern a +h2mPattern = \case + Hashing.Pattern.Unbound loc -> Memory.Pattern.Unbound loc + Hashing.Pattern.Var loc -> Memory.Pattern.Var loc + Hashing.Pattern.Boolean loc b -> Memory.Pattern.Boolean loc b + Hashing.Pattern.Int loc i -> Memory.Pattern.Int loc i + Hashing.Pattern.Nat loc n -> Memory.Pattern.Nat loc n + Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f + Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t + Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c + Hashing.Pattern.Constructor loc r i ps -> Memory.Pattern.Constructor loc (h2mReference r) i (h2mPattern <$> ps) + Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p) + Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p) + Hashing.Pattern.EffectBind loc r i ps k -> Memory.Pattern.EffectBind loc (h2mReference r) i (h2mPattern <$> ps) (h2mPattern k) + Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps) + Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r) + +h2mSequenceOp :: Hashing.Pattern.SeqOp -> Memory.Pattern.SeqOp +h2mSequenceOp = \case + Hashing.Pattern.Cons -> Memory.Pattern.Cons + Hashing.Pattern.Snoc -> Memory.Pattern.Snoc + Hashing.Pattern.Concat -> Memory.Pattern.Concat + +h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent +h2mReferent = \case + Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref) + Hashing.Referent.Con ref n ct -> Memory.Referent.Con (h2mReference ref) n ct + +hashDecls :: + Var v => + HashingInfo -> + Map v (Memory.DD.DataDeclaration v a) -> + ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] +hashDecls f memDecls = do + hashingDecls <- Validate.mapErrors (fmap CycleResolutionFailure) $ traverse (m2hDecl f) memDecls + hashingResult <- convertResolutionResult $ Hashing.DD.hashDecls hashingDecls + pure $ map h2mDeclResult hashingResult + where + h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) + h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) + +m2hDecl :: + Ord v => + HashingInfo -> + Memory.DD.DataDeclaration v a -> + Validate (Seq Hash) (Hashing.DD.DataDeclaration v a) +m2hDecl f (Memory.DD.DataDeclaration mod ann bound ctors) = + Hashing.DD.DataDeclaration (m2hModifier mod) ann bound + <$> traverse (Lens.mapMOf _3 (m2hType f)) ctors + +lookupHash :: HashingInfo -> Hash -> Validate (Seq Hash) Hashing.Reference.Size +lookupHash (HashingInfo f) h = case f h of + Just size -> pure size + Nothing -> Validate.refute $ pure h + +m2hType :: + Ord v => + HashingInfo -> + Memory.Type.Type v a -> + Validate (Seq Hash) (Hashing.Type.Type v a) +m2hType f = ABT.transformM \case + Memory.Type.Ref ref -> Hashing.Type.Ref <$> m2hReference f ref + Memory.Type.Arrow a1 a1' -> pure $ Hashing.Type.Arrow a1 a1' + Memory.Type.Ann a1 ki -> pure $ Hashing.Type.Ann a1 ki + Memory.Type.App a1 a1' -> pure $ Hashing.Type.App a1 a1' + Memory.Type.Effect a1 a1' -> pure $ Hashing.Type.Effect a1 a1' + Memory.Type.Effects a1s -> pure $ Hashing.Type.Effects a1s + Memory.Type.Forall a1 -> pure $ Hashing.Type.Forall a1 + Memory.Type.IntroOuter a1 -> pure $ Hashing.Type.IntroOuter a1 + +m2hReference :: + HashingInfo -> + Memory.Reference.Reference -> + Validate (Seq Hash) Hashing.Reference.Reference +m2hReference f = \case + Memory.Reference.Builtin t -> pure $ Hashing.Reference.Builtin t + Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId <$> m2hReferenceId f d + +m2hReferenceId :: + HashingInfo -> + Memory.Reference.Id -> + Validate (Seq Hash) Hashing.Reference.Id +m2hReferenceId f (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i <$> lookupHash f h + +h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier +h2mModifier = \case + Hashing.DD.Structural -> Memory.DD.Structural + Hashing.DD.Unique text -> Memory.DD.Unique text + +m2hModifier :: Memory.DD.Modifier -> Hashing.DD.Modifier +m2hModifier = \case + Memory.DD.Structural -> Hashing.DD.Structural + Memory.DD.Unique text -> Hashing.DD.Unique text + +h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a +h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = + Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) + +h2mType :: Ord v => Hashing.Type.Type v a -> Memory.Type.Type v a +h2mType = ABT.transform \case + Hashing.Type.Ref ref -> Memory.Type.Ref (h2mReference ref) + Hashing.Type.Arrow a1 a1' -> Memory.Type.Arrow a1 a1' + Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 ki + Hashing.Type.App a1 a1' -> Memory.Type.App a1 a1' + Hashing.Type.Effect a1 a1' -> Memory.Type.Effect a1 a1' + Hashing.Type.Effects a1s -> Memory.Type.Effects a1s + Hashing.Type.Forall a1 -> Memory.Type.Forall a1 + Hashing.Type.IntroOuter a1 -> Memory.Type.IntroOuter a1 + +h2mReference :: Hashing.Reference.Reference -> Memory.Reference.Reference +h2mReference = \case + Hashing.Reference.Builtin t -> Memory.Reference.Builtin t + Hashing.Reference.DerivedId d -> Memory.Reference.DerivedId (h2mReferenceId d) + +h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id +h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n diff --git a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs new file mode 100644 index 0000000000..f153f8513c --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + Modifier (..), + asDataDecl, + constructorType, + constructorTypes, + declDependencies, + dependencies, + bindReferences, + hashDecls, + ) +where + +import Control.Lens (over, _3) +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import qualified Unison.ABT as ABT +import qualified Unison.ConstructorType as CT +import Unison.Hash (Hash) +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Hashing.V1.Reference.Util as Reference.Util +import Unison.Hashing.V1.Type (Type) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Prelude +import Unison.Var (Var) +import Prelude hiding (cycle) +type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) + +data DeclOrBuiltin v a + = Builtin CT.ConstructorType + | Decl (Decl v a) + deriving (Eq, Show) + +asDataDecl :: Decl v a -> DataDeclaration v a +asDataDecl = either toDataDecl id + +declDependencies :: Ord v => Decl v a -> Set Reference +declDependencies = either (dependencies . toDataDecl) dependencies + +constructorType :: Decl v a -> CT.ConstructorType +constructorType = \case + Left {} -> CT.Effect + Right {} -> CT.Data + +data Modifier = Structural | Unique Text -- | Opaque (Set Reference) + deriving (Eq, Ord, Show) + +data DataDeclaration v a = DataDeclaration + { modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] + } + deriving (Eq, Show, Functor) + +newtype EffectDeclaration v a = EffectDeclaration + { toDataDecl :: DataDeclaration v a + } + deriving (Eq, Show, Functor) + +constructorTypes :: DataDeclaration v a -> [Type v a] +constructorTypes = (snd <$>) . constructors + +constructors :: DataDeclaration v a -> [(v, Type v a)] +constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] + +dependencies :: Ord v => DataDeclaration v a -> Set Reference +dependencies dd = + Set.unions (Type.dependencies <$> constructorTypes dd) + +toABT :: Var v => DataDeclaration v () -> ABT.Term F v () +toABT dd = ABT.tm $ Modified (modifier dd) dd' + where + dd' = ABT.absChain (bound dd) $ ABT.cycle + (ABT.absChain + (fst <$> constructors dd) + (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) + +-- Implementation detail of `hashDecls`, works with unannotated data decls +hashDecls0 :: (Eq v, Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] +hashDecls0 decls = + let abts = toABT <$> decls + ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) + cs = Reference.Util.hashComponents ref abts + in [(v, r) | (v, (r, _)) <- Map.toList cs] + +-- | compute the hashes of these user defined types and update any free vars +-- corresponding to these decls with the resulting hashes +-- +-- data List a = Nil | Cons a (List a) +-- becomes something like +-- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) +-- +-- NOTE: technical limitation, this implementation gives diff results if ctors +-- have the same FQN as one of the types. TODO: assert this and bomb if not +-- satisfied, or else do local mangling and unmangling to ensure this doesn't +-- affect the hash. +hashDecls :: + (Eq v, Var v, Show v) => + Map v (DataDeclaration v a) -> + Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] +hashDecls decls = do + -- todo: make sure all other external references are resolved before calling this + let varToRef = hashDecls0 (void <$> decls) + varToRef' = second Reference.DerivedId <$> varToRef + decls' = bindTypes <$> decls + bindTypes dd = dd {constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd} + typeReferences = Map.fromList (first Name.fromVar <$> varToRef') + -- normalize the order of the constructors based on a hash of their types + sortCtors dd = dd {constructors' = sortOn hash3 $ constructors' dd} + hash3 (_, _, typ) = ABT.hash typ :: Hash + decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' + pure [(v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls']] + +bindReferences :: + Var v => + Set v -> + Map Name.Name Reference -> + DataDeclaration v a -> + Names.ResolutionResult v a (DataDeclaration v a) +bindReferences keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.bindReferences keepFree names ty + pure $ DataDeclaration m a bound constructors + +data F a + = Type (Type.F a) + | LetRec [a] a + | Constructors [a] + | Modified Modifier a + deriving (Functor, Foldable, Show, Show1) + +instance Hashable1 F where + hash1 hashCycle hash e = + let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + in -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + Hashable.accumulate $ + tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +instance Hashable.Hashable Modifier where + tokens Structural = [Hashable.Tag 0] + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs new file mode 100644 index 0000000000..8453208239 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V1.LabeledDependency + ( derivedTerm + , derivedType + , termRef + , typeRef + , referent + , dataConstructor + , effectConstructor + , fold + , referents + , toReference + , LabeledDependency + , partition + ) where + +import Unison.Prelude hiding (fold) + +import qualified Data.Set as Set +import Unison.Hashing.V1.Reference (Id, Reference (DerivedId)) +import Unison.Hashing.V1.Referent (ConstructorId, Referent, pattern Con, pattern Ref) +import Unison.ConstructorType (ConstructorType (Data, Effect)) + +-- dumb constructor name is private +newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) + +derivedType, derivedTerm :: Id -> LabeledDependency +typeRef, termRef :: Reference -> LabeledDependency +referent :: Referent -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency + +derivedType = X . Left . DerivedId +derivedTerm = X . Right . Ref . DerivedId +typeRef = X . Left +termRef = X . Right . Ref +referent = X . Right +dataConstructor r cid = X . Right $ Con r cid Data +effectConstructor r cid = X . Right $ Con r cid Effect + +referents :: Foldable f => f Referent -> Set LabeledDependency +referents rs = Set.fromList (map referent $ toList rs) + +fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a +fold f g (X e) = either f g e + +partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) +partition = partitionEithers . map (\(X e) -> e) . toList + +-- | Left TypeRef | Right TermRef +toReference :: LabeledDependency -> Either Reference Reference +toReference = \case + X (Left r) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs new file mode 100644 index 0000000000..8647a1cb91 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs @@ -0,0 +1,156 @@ +{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} + +module Unison.Hashing.V1.Pattern where + +import Unison.Prelude + +import Data.Foldable as Foldable hiding (foldMap') +import Data.List (intercalate) +import qualified Data.Set as Set +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.Hashable as H + +type ConstructorId = Int + +data Pattern loc + = Unbound loc + | Var loc + | Boolean loc !Bool + | Int loc !Int64 + | Nat loc !Word64 + | Float loc !Double + | Text loc !Text + | Char loc !Char + | Constructor loc !Reference !Int [Pattern loc] + | As loc (Pattern loc) + | EffectPure loc (Pattern loc) + | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | SequenceLiteral loc [Pattern loc] + | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + deriving (Ord,Generic,Functor,Foldable,Traversable) + +data SeqOp = Cons + | Snoc + | Concat + deriving (Eq, Show, Ord, Generic) + +instance H.Hashable SeqOp where + tokens Cons = [H.Tag 0] + tokens Snoc = [H.Tag 1] + tokens Concat = [H.Tag 2] + +instance Show (Pattern loc) where + show (Unbound _ ) = "Unbound" + show (Var _ ) = "Var" + show (Boolean _ x) = "Boolean " <> show x + show (Int _ x) = "Int " <> show x + show (Nat _ x) = "Nat " <> show x + show (Float _ x) = "Float " <> show x + show (Text _ t) = "Text " <> show t + show (Char _ c) = "Char " <> show c + show (Constructor _ r i ps) = + "Constructor " <> unwords [show r, show i, show ps] + show (As _ p) = "As " <> show p + show (EffectPure _ k) = "EffectPure " <> show k + show (EffectBind _ r i ps k) = + "EffectBind " <> unwords [show r, show i, show ps, show k] + show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) + show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt + +application :: Pattern loc -> Bool +application (Constructor _ _ _ (_ : _)) = True +application _ = False + +loc :: Pattern loc -> loc +loc p = head $ Foldable.toList p + +setLoc :: Pattern loc -> loc -> Pattern loc +setLoc p loc = case p of + EffectBind _ a b c d -> EffectBind loc a b c d + EffectPure _ a -> EffectPure loc a + As _ a -> As loc a + Constructor _ a b c -> Constructor loc a b c + SequenceLiteral _ ps -> SequenceLiteral loc ps + SequenceOp _ ph op pt -> SequenceOp loc ph op pt + x -> fmap (const loc) x + +instance H.Hashable (Pattern p) where + tokens (Unbound _) = [H.Tag 0] + tokens (Var _) = [H.Tag 1] + tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] + tokens (Int _ n) = H.Tag 3 : [H.Int n] + tokens (Nat _ n) = H.Tag 4 : [H.Nat n] + tokens (Float _ f) = H.Tag 5 : H.tokens f + tokens (Constructor _ r n args) = + [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] + tokens (EffectPure _ p) = H.Tag 7 : H.tokens p + tokens (EffectBind _ r n args k) = + [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] + tokens (As _ p) = H.Tag 9 : H.tokens p + tokens (Text _ t) = H.Tag 10 : H.tokens t + tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps + tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r + tokens (Char _ c) = H.Tag 13 : H.tokens c + +instance Eq (Pattern loc) where + Unbound _ == Unbound _ = True + Var _ == Var _ = True + Boolean _ b == Boolean _ b2 = b == b2 + Int _ n == Int _ m = n == m + Nat _ n == Nat _ m = n == m + Float _ f == Float _ g = f == g + Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs + EffectPure _ p == EffectPure _ q = p == q + EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 + As _ p == As _ q = p == q + Text _ t == Text _ t2 = t == t2 + SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 + SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 + _ == _ = False + +foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m +foldMap' f p = case p of + Unbound _ -> f p + Var _ -> f p + Boolean _ _ -> f p + Int _ _ -> f p + Nat _ _ -> f p + Float _ _ -> f p + Text _ _ -> f p + Char _ _ -> f p + Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps + As _ p' -> f p <> foldMap' f p' + EffectPure _ p' -> f p <> foldMap' f p' + EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' + SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps + SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 + +generalizedDependencies + :: Ord r + => (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Pattern loc + -> Set r +generalizedDependencies literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . foldMap' + (\case + Unbound _ -> mempty + Var _ -> mempty + As _ _ -> mempty + Constructor _ r cid _ -> [dataType r, dataConstructor r cid] + EffectPure _ _ -> [effectType Type.effectRef] + EffectBind _ r cid _ _ -> + [effectType Type.effectRef, effectType r, effectConstructor r cid] + SequenceLiteral _ _ -> [literalType Type.listRef] + SequenceOp {} -> [literalType Type.listRef] + Boolean _ _ -> [literalType Type.booleanRef] + Int _ _ -> [literalType Type.intRef] + Nat _ _ -> [literalType Type.natRef] + Float _ _ -> [literalType Type.floatRef] + Text _ _ -> [literalType Type.textRef] + Char _ _ -> [literalType Type.charRef] + ) diff --git a/parser-typechecker/src/Unison/Hashing/V1/Reference.hs b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs new file mode 100644 index 0000000000..0202b44f5d --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Reference + (Reference, + pattern Builtin, + pattern Derived, + pattern DerivedId, + Id(..), + Pos, + Size, + derivedBase32Hex, + Component, members, + components, + groupByComponent, + componentFor, + unsafeFromText, + idFromText, + isPrefixOf, + fromShortHash, + fromText, + readSuffix, + showShort, + showSuffix, + toId, + toText, + unsafeId, + toShortHash, + idToShortHash) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Unison.Hash as H +import Unison.Hashable as Hashable +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import Data.Char (isDigit) + +-- | Either a builtin or a user defined (hashed) top-level declaration. +-- +-- Used for both terms and types. Doesn't distinguish between them. +-- +-- Other used defined things like local variables don't get @Reference@s. +data Reference + = Builtin Text.Text + -- `Derived` can be part of a strongly connected component. + -- The `Pos` refers to a particular element of the component + -- and the `Size` is the number of elements in the component. + -- Using an ugly name so no one tempted to use this + | DerivedId Id deriving (Eq,Ord,Generic) + +pattern Derived :: H.Hash -> Pos -> Size -> Reference +pattern Derived h i n = DerivedId (Id h i n) + +{-# COMPLETE Builtin, Derived #-} + +-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. +data Id = Id H.Hash Pos Size deriving (Generic) + +unsafeId :: Reference -> Id +unsafeId (Builtin b) = + error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." +unsafeId (DerivedId x) = x + +idToShortHash :: Id -> ShortHash +idToShortHash = toShortHash . DerivedId + +-- todo: move these to ShortHash module? +-- but Show Reference currently depends on SH +toShortHash :: Reference -> ShortHash +toShortHash (Builtin b) = SH.Builtin b +toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing +toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing + where + -- todo: remove `n` parameter; must also update readSuffix + index = Just $ showSuffix i n + +-- toShortHash . fromJust . fromShortHash == id and +-- fromJust . fromShortHash . toShortHash == id +-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it +-- may not be possible to base32Hex decode them. These will return Nothing. +-- Also, ShortHashes that include constructor ids will return Nothing; +-- try Referent.fromShortHash +fromShortHash :: ShortHash -> Maybe Reference +fromShortHash (SH.Builtin b) = Just (Builtin b) +fromShortHash (SH.ShortHash prefix cycle Nothing) = do + h <- H.fromBase32Hex prefix + case cycle of + Nothing -> Just (Derived h 0 1) + Just t -> case Text.splitOn "c" t of + [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) + _ -> Nothing +fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing + +-- (3,10) encoded as "3c10" +-- (0,93) encoded as "0c93" +showSuffix :: Pos -> Size -> Text +showSuffix i n = Text.pack $ show i <> "c" <> show n + +-- todo: don't read or return size; must also update showSuffix and fromText +readSuffix :: Text -> Either String (Pos, Size) +readSuffix t = case Text.breakOn "c" t of + (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> + Right (read (Text.unpack pos), read (Text.unpack size)) + _ -> Left "suffix decoding error" + +isPrefixOf :: ShortHash -> Reference -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +toText :: Reference -> Text +toText = SH.toText . toShortHash + +showShort :: Int -> Reference -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +type Pos = Word64 +type Size = Word64 + +newtype Component = Component { members :: Set Reference } + +-- Gives the component (dependency cycle) that the reference is a part of +componentFor :: Reference -> Component +componentFor b@Builtin {} = Component (Set.singleton b) +componentFor (Derived h _ n) = + Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] + +derivedBase32Hex :: Text -> Pos -> Size -> Reference +derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) + where + msg = error $ "Reference.derivedBase32Hex " <> show h + h = H.fromBase32Hex b32Hex + +unsafeFromText :: Text -> Reference +unsafeFromText = either error id . fromText + +idFromText :: Text -> Maybe Id +idFromText s = case fromText s of + Left _ -> Nothing + Right (Builtin _) -> Nothing + Right (DerivedId id) -> pure id + +toId :: Reference -> Maybe Id +toId (DerivedId id) = Just id +toId Builtin{} = Nothing + +-- examples: +-- `##Text.take` β€” builtins don’t have cycles +-- `#2tWjVAuc7` β€” derived, no cycle +-- `#y9ycWkiC1.y9` β€” derived, part of cycle +-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. +fromText :: Text -> Either String Reference +fromText t = case Text.split (=='#') t of + [_, "", b] -> Right (Builtin b) + [_, h] -> case Text.split (=='.') h of + [hash] -> Right (derivedBase32Hex hash 0 1) + [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix + _ -> bail + _ -> bail + where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t + +component :: H.Hash -> [k] -> [(k, Id)] +component h ks = let + size = fromIntegral (length ks) + in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] + +components :: [(H.Hash, [k])] -> [(k, Id)] +components sccs = uncurry component =<< sccs + +groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] +groupByComponent refs = done $ foldl' insert Map.empty refs + where + insert m (k, r@(Derived h _ _)) = + Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) + insert m (k, r) = + Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) + done m = sortOn snd <$> toList m + +instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId +instance Show Reference where show = SH.toString . SH.take 5 . toShortHash + +instance Hashable.Hashable Reference where + tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] + tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] + +-- | Two references mustn't differ in cycle length only. +instance Eq Id where x == y = compare x y == EQ +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs b/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs new file mode 100644 index 0000000000..e954492f44 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs @@ -0,0 +1,21 @@ +module Unison.Hashing.V1.Reference.Util where + +import Unison.Prelude + +import qualified Unison.Hashing.V1.Reference as Reference +import Unison.Hashable (Hashable1) +import Unison.ABT (Var) +import qualified Unison.ABT as ABT +import qualified Data.Map as Map + +hashComponents :: + (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) + => (Reference.Id -> ABT.Term f v ()) + -> Map v (ABT.Term f v a) + -> Map v (Reference.Id, ABT.Term f v a) +hashComponents embedRef tms = + Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) + + diff --git a/parser-typechecker/src/Unison/Hashing/V1/Referent.hs b/parser-typechecker/src/Unison/Hashing/V1/Referent.hs new file mode 100644 index 0000000000..b5a5035ebe --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Referent.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V1.Referent where + +import Unison.Prelude +import Unison.Referent' ( Referent'(..), toReference' ) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as R +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH + +import Unison.ConstructorType (ConstructorType) +import qualified Unison.ConstructorType as CT + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. +type Referent = Referent' Reference +type ConstructorId = Int +pattern Ref :: Reference -> Referent +pattern Ref r = Ref' r +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent +pattern Con r i t = Con' r i t +{-# COMPLETE Ref, Con #-} + +-- | Cannot be a builtin. +type Id = Referent' R.Id + +-- referentToTerm moved to Term.fromReferent +-- termToReferent moved to Term.toReferent + +-- todo: move these to ShortHash module +toShortHash :: Referent -> ShortHash +toShortHash = \case + Ref r -> R.toShortHash r + Con r i _ -> patternShortHash r i + +toShortHashId :: Id -> ShortHash +toShortHashId = toShortHash . fromId + +-- also used by HashQualified.fromPattern +patternShortHash :: Reference -> ConstructorId -> ShortHash +patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } + +showShort :: Int -> Referent -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +toText :: Referent -> Text +toText = \case + Ref r -> R.toText r + Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) + +ctorTypeText :: CT.ConstructorType -> Text +ctorTypeText CT.Effect = EffectCtor +ctorTypeText CT.Data = DataCtor + +pattern EffectCtor = "a" +pattern DataCtor = "d" + +toString :: Referent -> String +toString = Text.unpack . toText + +isConstructor :: Referent -> Bool +isConstructor Con{} = True +isConstructor _ = False + +toTermReference :: Referent -> Maybe Reference +toTermReference = \case + Ref r -> Just r + _ -> Nothing + +toReference :: Referent -> Reference +toReference = toReference' + +fromId :: Id -> Referent +fromId = fmap R.DerivedId + +toTypeReference :: Referent -> Maybe Reference +toTypeReference = \case + Con r _i _t -> Just r + _ -> Nothing + +isPrefixOf :: ShortHash -> Referent -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +unsafeFromText :: Text -> Referent +unsafeFromText = fromMaybe (error "invalid referent") . fromText + +-- #abc[.xy][#cid] +fromText :: Text -> Maybe Referent +fromText t = either (const Nothing) Just $ + -- if the string has just one hash at the start, it's just a reference + if Text.length refPart == 1 then + Ref <$> R.fromText t + else if Text.all Char.isDigit cidPart then do + r <- R.fromText (Text.dropEnd 1 refPart) + ctorType <- ctorType + let cid = read (Text.unpack cidPart) + pure $ Con r cid ctorType + else + Left ("invalid constructor id: " <> Text.unpack cidPart) + where + ctorType = case Text.take 1 cidPart' of + EffectCtor -> Right CT.Effect + DataCtor -> Right CT.Data + _otherwise -> + Left ("invalid constructor type (expected '" + <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') + refPart = Text.dropWhileEnd (/= '#') t + cidPart' = Text.takeWhileEnd (/= '#') t + cidPart = Text.drop 1 cidPart' + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct diff --git a/parser-typechecker/src/Unison/Hashing/V1/Term.hs b/parser-typechecker/src/Unison/Hashing/V1/Term.hs new file mode 100644 index 0000000000..27ee4fdbb2 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Term.hs @@ -0,0 +1,1120 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Term where + +import Unison.Prelude + +import Prelude hiding (and,or) +import Control.Monad.State (evalState) +import qualified Control.Monad.Writer.Strict as Writer +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Sequence as Sequence +import Prelude.Extras (Eq1(..), Show1(..)) +import Text.Show +import qualified Unison.ABT as ABT +import qualified Unison.Blank as B +import qualified Unison.Hash as Hash +import Unison.Hashable (Hashable1, accumulateToken) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V1.Pattern (Pattern) +import qualified Unison.Hashing.V1.Pattern as Pattern +import Unison.Hashing.V1.Reference (Reference, pattern Builtin) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Hashing.V1.Reference.Util as ReferenceUtil +import Unison.Hashing.V1.Referent (Referent) +import qualified Unison.Hashing.V1.Referent as Referent +import Unison.Hashing.V1.Type (Type) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Util.List (multimap) +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unsafe.Coerce +import Unison.Symbol (Symbol) +import qualified Unison.Hashing.V1.LabeledDependency as LD +import Unison.Hashing.V1.LabeledDependency (LabeledDependency) + +-- This gets reexported; should maybe live somewhere other than Pattern, though. +type ConstructorId = Pattern.ConstructorId + +data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a + deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) + +-- | Base functor for terms in the Unison language +-- We need `typeVar` because the term and type variables may differ. +data F typeVar typeAnn patternAnn a + = Int Int64 + | Nat Word64 + | Float Double + | Boolean Bool + | Text Text + | Char Char + | Blank (B.Blank typeAnn) + | Ref Reference + -- First argument identifies the data type, + -- second argument identifies the constructor + | Constructor Reference ConstructorId + | Request Reference ConstructorId + | Handle a a + | App a a + | Ann a (Type typeVar typeAnn) + | List (Seq a) + | If a a a + | And a a + | Or a a + | Lam a + -- Note: let rec blocks have an outer ABT.Cycle which introduces as many + -- variables as there are bindings + | LetRec IsTop [a] a + -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + | Let IsTop a a + -- Pattern matching / eliminating data types, example: + -- case x of + -- Just n -> rhs1 + -- Nothing -> rhs2 + -- + -- translates to + -- + -- Match x + -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- , (Constructor 1 [], rhs2) ] + | Match a [MatchCase patternAnn a] + | TermLink Referent + | TypeLink Reference + deriving (Foldable,Functor,Generic,Generic1,Traversable) + +type IsTop = Bool + +-- | Like `Term v`, but with an annotation of type `a` at every level in the tree +type Term v a = Term2 v a a v a +-- | Allow type variables and term variables to differ +type Term' vt v a = Term2 vt a a v a +-- | Allow type variables, term variables, type annotations and term annotations +-- to all differ +type Term2 vt at ap v a = ABT.Term (F vt at ap) v a +-- | Like `Term v a`, but with only () for type and pattern annotations. +type Term3 v a = Term2 v () () v a + +-- | Terms are represented as ABTs over the base functor F, with variables in `v` +type Term0 v = Term v () +-- | Terms with type variables in `vt`, and term variables in `v` +type Term0' vt v = Term' vt v () + +-- Prepare a term for type-directed name resolution by replacing +-- any remaining free variables with blanks to be resolved by TDNR +prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b +prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t + where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = + Just $ resolve (a, bound) a (Text.unpack $ Var.name v) + f _ = Nothing + +amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 +amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) + +patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a +patternMap f = go where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ + MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) + -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a +vmap f = ABT.vmap f . typeMap (ABT.vmap f) + +vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a +vtmap f = typeMap (ABT.vmap f) + +typeMap + :: Ord vt2 + => (Type vt at -> Type vt2 at2) + -> Term2 vt at ap v a + -> Term2 vt2 at2 ap v a +typeMap f = go + where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) + -- Safe since `Ann` is only ctor that has embedded `Type v` arg + -- otherwise we'd have to manually match on every non-`Ann` ctor + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +extraMap' + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> Term2 vt at ap v a + -> Term2 vt' at' ap' v a +extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) + +extraMap + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> F vt at ap a + -> F vt' at' ap' a +extraMap vtf atf apf = \case + Int x -> Int x + Nat x -> Nat x + Float x -> Float x + Boolean x -> Boolean x + Text x -> Text x + Char x -> Char x + Blank x -> Blank (fmap atf x) + Ref x -> Ref x + Constructor x y -> Constructor x y + Request x y -> Request x y + Handle x y -> Handle x y + App x y -> App x y + Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) + List x -> List x + If x y z -> If x y z + And x y -> And x y + Or x y -> Or x y + Lam x -> Lam x + LetRec x y z -> LetRec x y z + Let x y z -> Let x y z + Match tm l -> Match tm (map (matchCaseExtraMap apf) l) + TermLink r -> TermLink r + TypeLink r -> TypeLink r + +matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a +matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y + +unannotate + :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v +unannotate = go + where + go :: Term2 vt at ap v a -> Term0' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v ) = ABT.var v + go (ABT.Tm' f ) = case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + +wrapV :: Ord v => Term v a -> Term (ABT.V v) a +wrapV = vmap ABT.Bound + +-- | All variables mentioned in the given term. +-- Includes both term and type variables, both free and bound. +allVars :: Ord v => Term v a -> Set v +allVars tm = Set.fromList $ + ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] + where + allTypes tm = case tm of + Ann' e tp -> tp : allTypes e + _ -> foldMap allTypes $ ABT.out tm + +freeVars :: Term' vt v a -> Set v +freeVars = ABT.freeVars + +freeTypeVars :: Ord vt => Term' vt v a -> Set vt +freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t + +freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] +freeTypeVarAnnotations e = multimap $ go Set.empty e where + go bound tm = case tm of + Var' _ -> mempty + Ann' e (Type.stripIntroOuters -> t1) -> let + bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs + _ -> bound + in go bound' e <> ABT.freeVarOccurrences bound t1 + ABT.Tm' f -> foldMap (go bound) f + (ABT.out -> ABT.Abs _ body) -> go bound body + (ABT.out -> ABT.Cycle body) -> go bound body + _ -> error "unpossible" + +substTypeVars :: (Ord v, Var vt) + => [(vt, Type vt b)] + -> Term' vt v a + -> Term' vt v a +substTypeVars subs e = foldl' go e subs where + go e (vt, t) = substTypeVar vt t e + +-- Capture-avoiding substitution of a type variable inside a term. This +-- will replace that type variable wherever it appears in type signatures of +-- the term, avoiding capture by renaming βˆ€-binders. +substTypeVar + :: (Ord v, ABT.Var vt) + => vt + -> Type vt b + -> Term' vt v a + -> Term' vt v a +substTypeVar vt ty = go Set.empty where + go bound tm | Set.member vt bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where + fvs = ABT.freeVars ty + -- if the βˆ€ introduces a variable, v, which is free in `ty`, we pick a new + -- variable name for v which is unique, v', and rename v to v' in e. + uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let + v = ABT.variable body + v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v + t2 = ABT.bindInheritAnnotation body (Type.var() v2) + in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 + uncapture vs e t0 = let + t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a +renameTypeVar old new = go Set.empty where + go bound tm | Set.member old bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> let + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.rename old new (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- Converts free variables to bound variables using forall or introOuter. Example: +-- +-- foo : x -> x +-- foo a = +-- r : x +-- r = a +-- r +-- +-- This becomes: +-- +-- foo : βˆ€ x . x -> x +-- foo a = +-- r : outer x . x -- FYI, not valid syntax +-- r = a +-- r +-- +-- More specifically: in the expression `e : t`, unbound lowercase variables in `t` +-- are bound with foralls, and any βˆ€-quantified type variables are made bound in +-- `e` and its subexpressions. The result is a term with no lowercase free +-- variables in any of its type signatures, with outer references represented +-- with explicit `introOuter` binders. The resulting term may have uppercase +-- free variables that are still unbound. +generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a +generalizeTypeSignatures = go Set.empty where + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e (Type.generalizeLowercase bound -> t) -> let + bound' = case Type.unForalls t of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + in ann loc (go bound' e) (Type.freeVarsToOuters bound t) + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- nicer pattern syntax + +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst +pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) +pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) +pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) +pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) +pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) +pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) +pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) +pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) +pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) +pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) +pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) +pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) +pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) +pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) +pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) +pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) +pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) +pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) +pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) +pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) +pattern Apps' f args <- (unApps -> Just (f, args)) +-- begin pretty-printer helper patterns +pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) +pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) +pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) +pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +-- end pretty-printer helper patterns +pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) +pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) +pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) + +pattern Delay' body <- (unDelay -> Just body) +unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) +unDelay tm = case ABT.out tm of + ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) + | Set.notMember v (ABT.freeVars body) + -> Just body + _ -> Nothing + +pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) +pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) +pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) +pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) +pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) +pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) +pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) +pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) +pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) +pattern Lets' bs e <- (unLet -> Just (bs, e)) +pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) +pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) +pattern LetRec' subst <- (unLetRec -> Just (_, subst)) +pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) +pattern LetRecNamedAnnotatedTop' top ann bs e <- + (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) + +fresh :: Var v => Term0 v -> v -> v +fresh = ABT.fresh + +-- some smart constructors + +var :: a -> v -> Term2 vt at ap v a +var = ABT.annotatedVar + +var' :: Var v => Text -> Term0' vt v +var' = var() . Var.named + +ref :: Ord v => a -> Reference -> Term2 vt at ap v a +ref a r = ABT.tm' a (Ref r) + +pattern Referent' r <- (unReferent -> Just r) + +unReferent :: Term2 vt at ap v a -> Maybe Referent +unReferent (Ref' r) = Just $ Referent.Ref r +unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data +unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect +unReferent _ = Nothing + +refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Referent -> Term2 vt at ap v a +termLink a r = ABT.tm' a (TermLink r) + +typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a +typeLink a r = ABT.tm' a (TypeLink r) + +builtin :: Ord v => a -> Text -> Term2 vt at ap v a +builtin a n = ref a (Reference.Builtin n) + +float :: Ord v => a -> Double -> Term2 vt at ap v a +float a d = ABT.tm' a (Float d) + +boolean :: Ord v => a -> Bool -> Term2 vt at ap v a +boolean a b = ABT.tm' a (Boolean b) + +int :: Ord v => a -> Int64 -> Term2 vt at ap v a +int a d = ABT.tm' a (Int d) + +nat :: Ord v => a -> Word64 -> Term2 vt at ap v a +nat a d = ABT.tm' a (Nat d) + +text :: Ord v => a -> Text -> Term2 vt at ap v a +text a = ABT.tm' a . Text + +char :: Ord v => a -> Char -> Term2 vt at ap v a +char a = ABT.tm' a . Char + +watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a +watch a note e = + apps' (builtin a "Debug.watch") [text a (Text.pack note), e] + +watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a +watchMaybe Nothing e = e +watchMaybe (Just note) e = watch (ABT.annotation e) note e + +blank :: Ord v => a -> Term2 vt at ap v a +blank a = ABT.tm' a (Blank B.Blank) + +placeholder :: Ord v => a -> String -> Term2 vt a ap v a +placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) + +resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at +resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) + +constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +constructor a ref n = ABT.tm' a (Constructor ref n) + +request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +request a ref n = ABT.tm' a (Request ref n) + +-- todo: delete and rename app' to app +app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v +app_ f arg = ABT.tm (App f arg) + +app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +app a f arg = ABT.tm' a (App f arg) + +match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a +match a scrutinee branches = ABT.tm' a (Match scrutinee branches) + +handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +handle a h block = ABT.tm' a (Handle h block) + +and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +and a x y = ABT.tm' a (And x y) + +or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +or a x y = ABT.tm' a (Or x y) + +list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a +list a es = list' a (Sequence.fromList es) + +list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a +list' a es = ABT.tm' a (List es) + +apps + :: Ord v + => Term2 vt at ap v a + -> [(a, Term2 vt at ap v a)] + -> Term2 vt at ap v a +apps = foldl' (\f (a, t) -> app a f t) + +apps' + :: (Ord v, Semigroup a) + => Term2 vt at ap v a + -> [Term2 vt at ap v a] + -> Term2 vt at ap v a +apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) + +iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +iff a cond t f = ABT.tm' a (If cond t f) + +ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v +ann_ e t = ABT.tm (Ann e t) + +ann :: Ord v + => a + -> Term2 vt at ap v a + -> Type vt at + -> Term2 vt at ap v a +ann a e t = ABT.tm' a (Ann e t) + +-- arya: are we sure we want the two annotations to be the same? +lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a +lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) + +delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a +delay a body = + ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) + +lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam'' vs body = foldr (uncurry lam) body vs + +isLam :: Term2 vt at ap v a -> Bool +isLam t = arity t > 0 + +arity :: Term2 vt at ap v a -> Int +arity (LamNamed' _ body) = 1 + arity body +arity (Ann' e _) = arity e +arity _ = 0 + +unLetRecNamedAnnotated + :: Term' vt v a + -> Maybe + (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) +unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = + Just (isTop, ann, avs `zip` bs, e) +unLetRecNamedAnnotated _ = Nothing + +letRec' + :: (Ord v, Monoid a) + => Bool + -> [(v, Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec' isTop bindings body = + letRec isTop + (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) + [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] + body + +-- Prepend a binding to form a (bigger) let rec. Useful when +-- building up a block incrementally using a right fold. +-- +-- For example: +-- consLetRec (x = 42) "hi" +-- => +-- let rec x = 42 in "hi" +-- +-- consLetRec (x = 42) (let rec y = "hi" in (x,y)) +-- => +-- let rec x = 42; y = "hi" in (x,y) +consLetRec + :: Ord v + => Bool -- isTop parameter + -> a -- annotation for overall let rec + -> (a, v, Term' vt v a) -- the binding + -> Term' vt v a -- the body + -> Term' vt v a +consLetRec isTop a (ab, vb, b) body = case body of + LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body + _ -> letRec isTop a [((ab,vb),b)] body + +letRec + :: Ord v + => Bool + -> a + -> [((a, v), Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec _ _ [] e = e +letRec isTop a bindings e = ABT.cycle' + a + (foldr (uncurry ABT.abs' . fst) z bindings) + where z = ABT.tm' a (LetRec isTop (map snd bindings) e) + + +-- | Smart constructor for let rec blocks. Each binding in the block may +-- reference any other binding in the block in its body (including itself), +-- and the output expression may also reference any binding in the block. +letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v +letRec_ _ [] e = e +letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) + where + z = ABT.tm (LetRec isTop (map snd bindings) e) + +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. +-- todo: delete me +let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v +let1_ isTop bindings e = foldr f e bindings + where + f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) + +-- | annotations are applied to each nested Let expression +let1 + :: Ord v + => IsTop + -> [((a, v), Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1 isTop bindings e = foldr f e bindings + where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) + +let1' + :: (Semigroup a, Ord v) + => IsTop + -> [(v, Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1' isTop bindings e = foldr f e bindings + where + ann = ABT.annotation + f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) + where a = ann b <> ann body + +-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v +-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e + +unLet1 + :: Var v + => Term' vt v a + -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) +unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) +unLet1 _ = Nothing + +-- | Satisfies `unLet (let' bs e) == Just (bs, e)` +unLet + :: Term2 vt at ap v a + -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) +unLet t = fixup (go t) + where + go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of + (env, t) -> ((isTop, v, b) : env, t) + go t = ([], t) + fixup ([], _) = Nothing + fixup bst = Just bst + +-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` +unLetRecNamed + :: Term2 vt at ap v a + -> Maybe + ( IsTop + , [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) + | length vs == length bs = Just (isTop, zip vs bs, e) +unLetRecNamed _ = Nothing + +unLetRec + :: (Monad m, Var v) + => Term2 vt at ap v a + -> Maybe + ( IsTop + , (v -> m v) + -> m + ( [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) + ) +unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just + ( isTop + , \freshen -> do + vs <- sequence [ freshen v | (v, _) <- bs ] + let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) + pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) + ) +unLetRec _ = Nothing + +unApps + :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unApps t = unAppsPred (t, const True) + +-- Same as unApps but taking a predicate controlling whether we match on a given function argument. +unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) + where + go (App' i o) acc | pred o = go i (o:acc) + go _ [] = [] + go fn args = fn:args + +unBinaryApp :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a) +unBinaryApp t = case unApps t of + Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) + _ -> Nothing + +-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" +unBinaryApps + :: Term2 vt at ap v a + -> Maybe + ( [(Term2 vt at ap v a, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unBinaryApps t = unBinaryAppsPred (t, const True) + +-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. +unBinaryAppsPred :: (Term2 vt at ap v a + ,Term2 vt at ap v a -> Bool) + -> Maybe ([(Term2 vt at ap v a, + Term2 vt at ap v a)], + Term2 vt at ap v a) +unBinaryAppsPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + _ -> Nothing + +unLams' + :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLams' t = unLamsPred' (t, const True) + +-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a +-- lambda extraction. +unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLamsOpt' t = case unLams' t of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams', but stops at any variable named `()`, which indicates a +-- delay (`'`) annotation which we want to preserve. +unLamsUntilDelay' + :: Var v + => Term2 vt at ap v a + -> Maybe ([v], Term2 vt at ap v a) +unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams' but taking a predicate controlling whether we match on a given binary function. +unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> + Maybe ([v], Term2 vt at ap v a) +unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of + Nothing -> Just ([v], body) + Just (vs, body) -> Just (v:vs, body) +unLamsPred' _ = Nothing + +unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) +unReqOrCtor (Constructor' r cid) = Just (r, cid) +unReqOrCtor (Request' r cid) = Just (r, cid) +unReqOrCtor _ = Nothing + +-- Dependencies including referenced data and effect decls +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) + +termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +termDependencies = + Set.fromList + . mapMaybe + ( LD.fold + (\_typeRef -> Nothing) + ( Referent.fold + (\termRef -> Just termRef) + (\_typeConRef _i _ct -> Nothing) + ) + ) + . toList + . labeledDependencies + +-- gets types from annotations and constructors +typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +typeDependencies = + Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + +-- Gets the types to which this term contains references via patterns and +-- data constructors. +constructorDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +constructorDependencies = + Set.unions + . generalizedDependencies (const mempty) + (const mempty) + Set.singleton + (const . Set.singleton) + Set.singleton + (const . Set.singleton) + Set.singleton + +generalizedDependencies + :: (Ord v, Ord vt, Ord r) + => (Reference -> r) + -> (Reference -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Term2 vt at ap v a + -> Set r +generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . Writer.execWriter . ABT.visit' f where + f t@(Ref r) = Writer.tell [termRef r] $> t + f t@(TermLink r) = case r of + Referent.Ref r -> Writer.tell [termRef r] $> t + Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t + Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t + f t@(TypeLink r) = Writer.tell [typeRef r] $> t + f t@(Ann _ typ) = + Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t + f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t + f t@(Int _) = Writer.tell [literalType Type.intRef] $> t + f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t + f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t + f t@(Text _) = Writer.tell [literalType Type.textRef] $> t + f t@(List _) = Writer.tell [literalType Type.listRef] $> t + f t@(Constructor r cid) = + Writer.tell [dataType r, dataConstructor r cid] $> t + f t@(Request r cid) = + Writer.tell [effectType r, effectConstructor r cid] $> t + f t@(Match _ cases) = traverse_ goPat cases $> t + f t = pure t + goPat (MatchCase pat _ _) = + Writer.tell . toList $ Pattern.generalizedDependencies literalType + dataConstructor + dataType + effectConstructor + effectType + pat + +labeledDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.termRef + LD.typeRef + LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef + +updateDependencies + :: Ord v + => Map Reference Reference + -> Map Reference Reference + -> Term v a + -> Term v a +updateDependencies termUpdates typeUpdates = ABT.rebuildUp go + where + -- todo: this function might need tweaking if we ever allow type replacements + -- would need to look inside pattern matching and constructor calls + go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) + go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) + go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) + go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp + go f = f + +-- | If the outermost term is a function application, +-- perform substitution of the argument into the body +betaReduce :: Var v => Term0 v -> Term0 v +betaReduce (App' (Lam' f) arg) = ABT.bind f arg +betaReduce e = e + +betaNormalForm :: Var v => Term0 v -> Term0 v +betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) +betaNormalForm e = e + +-- x -> f x => f +etaNormalForm :: Ord v => Term0 v -> Term0 v +etaNormalForm tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + where + step (LamNamed' v (App' f (Var' v'))) | v == v' = f + step tm = tm + _ -> tm + +-- x -> f x => f as long as `x` is a variable of type `Var.Eta` +etaReduceEtaVars :: Var v => Term0 v -> Term0 v +etaReduceEtaVars tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + where + ok v v' = v == v' && Var.typeOf v == Var.Eta + step (LamNamed' v (App' f (Var' v'))) | ok v v' = f + step tm = tm + _ -> tm + +-- This converts `Reference`s it finds that are in the input `Map` +-- back to free variables +unhashComponent :: forall v a. Var v + => Map Reference (Term v a) + -> Map Reference (v, Term v a) +unhashComponent m = let + usedVars = foldMap (Set.fromList . ABT.allVars) m + m' :: Map Reference (v, Term v a) + m' = evalState (Map.traverseWithKey assignVar m) usedVars where + assignVar r t = (,t) <$> ABT.freshenS (refNamed r) + unhash1 = ABT.rebuildUp' go where + go e@(Ref' r) = case Map.lookup r m' of + Nothing -> e + Just (v, _) -> var (ABT.annotation e) v + go e = e + in second unhash1 <$> m' + where + -- Variable whose name is derived from the given reference. + refNamed :: Var v => Reference -> v + refNamed ref = Var.named ("ℍ" <> Reference.toText ref) + +hashComponents + :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +hashClosedTerm :: Var v => Term v a -> Reference.Id +hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 + +-- The hash for a constructor +hashConstructor' + :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +hashConstructor' f r cid = + let +-- this is a bit circuitous, but defining everything in terms of hashComponents +-- ensure the hashing is always done in the same way + m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) + in case toList m of + [(r, _)] -> Reference.DerivedId r + _ -> error "unpossible" + +hashConstructor :: Reference -> ConstructorId -> Reference +hashConstructor = hashConstructor' $ constructor () + +hashRequest :: Reference -> ConstructorId -> Reference +hashRequest = hashConstructor' $ request () + +fromReferent :: Ord v + => a + -> Referent + -> Term2 vt at ap v a +fromReferent a = \case + Referent.Ref r -> ref a r + Referent.Con r i ct -> case ct of + CT.Data -> constructor a r i + CT.Effect -> request a r i + +instance Var v => Hashable1 (F v a p) where + hash1 hashCycle hash e + = let (tag, hashed, varint) = + (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) + in + case e of + -- So long as `Reference.Derived` ctors are created using the same + -- hashing function as is used here, this case ensures that references + -- are 'transparent' wrt hash and hashing is unaffected by whether + -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash + -- the same. + Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) + Ref (Reference.Derived h i n) -> Hashable.accumulate + [ tag 1 + , hashed $ Hashable.fromBytes (Hash.toBytes h) + , Hashable.Nat i + , Hashable.Nat n + ] + -- Note: start each layer with leading `1` byte, to avoid collisions + -- with types, which start each layer with leading `0`. + -- See `Hashable1 Type.F` + _ -> + Hashable.accumulate + $ tag 1 + : case e of + Nat i -> [tag 64, accumulateToken i] + Int i -> [tag 65, accumulateToken i] + Float n -> [tag 66, Hashable.Double n] + Boolean b -> [tag 67, accumulateToken b] + Text t -> [tag 68, accumulateToken t] + Char c -> [tag 69, accumulateToken c] + Blank b -> tag 1 : case b of + B.Blank -> [tag 0] + B.Recorded (B.Placeholder _ s) -> + [tag 1, Hashable.Text (Text.pack s)] + B.Recorded (B.Resolve _ s) -> + [tag 2, Hashable.Text (Text.pack s)] + Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] + Ref Reference.Derived {} -> + error "handled above, but GHC can't figure this out" + App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] + Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] + List as -> tag 5 : varint (Sequence.length as) : map + (hashed . hash) + (toList as) + Lam a -> [tag 6, hashed (hash a)] + -- note: we use `hashCycle` to ensure result is independent of + -- let binding order + LetRec _ as a -> case hashCycle as of + (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs + -- here, order is significant, so don't use hashCycle + Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + If b t f -> + [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] + Request r n -> [tag 10, accumulateToken r, varint n] + Constructor r n -> [tag 12, accumulateToken r, varint n] + Match e branches -> + tag 13 : hashed (hash e) : concatMap h branches + where + h (MatchCase pat guard branch) = concat + [ [accumulateToken pat] + , toList (hashed . hash <$> guard) + , [hashed (hash branch)] + ] + Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] + And x y -> [tag 16, hashed $ hash x, hashed $ hash y] + Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] + TermLink r -> [tag 18, accumulateToken r] + TypeLink r -> [tag 19, accumulateToken r] + +-- mostly boring serialization code below ... + +instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec + +instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where + Int x == Int y = x == y + Nat x == Nat y = x == y + Float x == Float y = x == y + Boolean x == Boolean y = x == y + Text x == Text y = x == y + Char x == Char y = x == y + Blank b == Blank q = b == q + Ref x == Ref y = x == y + TermLink x == TermLink y = x == y + TypeLink x == TypeLink y = x == y + Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 + Request r cid == Request r2 cid2 = r == r2 && cid == cid2 + Handle h b == Handle h2 b2 = h == h2 && b == b2 + App f a == App f2 a2 = f == f2 && a == a2 + Ann e t == Ann e2 t2 = e == e2 && t == t2 + List v == List v2 = v == v2 + If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 + And a b == And a2 b2 = a == a2 && b == b2 + Or a b == Or a2 b2 = a == a2 && b == b2 + Lam a == Lam b = a == b + LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 + Let _ binding body == Let _ binding2 body2 = + binding == binding2 && body == body2 + Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 + _ == _ = False + + +instance (Show v, Show a) => Show (F v a0 p a) where + showsPrec = go + where + go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n + go _ (Nat n ) = shows n + go _ (Float n ) = shows n + go _ (Boolean True ) = s "true" + go _ (Boolean False) = s "false" + go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k + go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x + go _ (Lam body ) = showParen True (s "Ξ» " <> shows body) + go _ (List vs ) = showListWith shows (toList vs) + go _ (Blank b ) = case b of + B.Blank -> s "_" + B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) + B.Recorded (B.Resolve _ r) -> s r + go _ (Ref r) = s "Ref(" <> shows r <> s ")" + go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" + go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" + go _ (Let _ b body) = + showParen True (s "let " <> shows b <> s " in " <> shows body) + go _ (LetRec _ bs body) = showParen + True + (s "let rec" <> shows bs <> s " in " <> shows body) + go _ (Handle b body) = showParen + True + (s "handle " <> shows b <> s " in " <> shows body) + go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n + go _ (Match scrutinee cases) = showParen + True + (s "case " <> shows scrutinee <> s " of " <> shows cases) + go _ (Text s ) = shows s + go _ (Char c ) = shows c + go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n + go p (If c t f) = + showParen (p > 0) + $ s "if " + <> shows c + <> s " then " + <> shows t + <> s " else " + <> shows f + go p (And x y) = + showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y + go p (Or x y) = + showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y + (<>) = (.) + s = showString \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Type.hs b/parser-typechecker/src/Unison/Hashing/V1/Type.hs new file mode 100644 index 0000000000..da4b183c73 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Type.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Type where + +import Unison.Prelude + +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Hashing.V1.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +-- | Base functor for types in the Unison language +data F a + = Ref Reference + | Arrow a a + | Ann a K.Kind + | App a a + | Effect a a + | Effects [a] + | Forall a + | IntroOuter a -- binder like βˆ€, used to introduce variables that are + -- bound by outer type signatures, to support scoped type + -- variables + deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) + +instance Eq1 F where (==#) = (==) +instance Ord1 F where compare1 = compare +instance Show1 F where showsPrec1 = showsPrec + +-- | Types are represented as ABTs over the base functor F, with variables in `v` +type Type v a = ABT.Term F v a + +wrapV :: Ord v => Type v a -> Type (ABT.V v) a +wrapV = ABT.vmap ABT.Bound + +freeVars :: Type v a -> Set v +freeVars = ABT.freeVars + +bindExternal + :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a +bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] + +bindReferences + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindReferences keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +bindNames + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq + +instance (Show v) => Show (Monotype v a) where + show = show . getPolytype + +-- Smart constructor which checks if a `Type` has no `Forall` quantifiers. +monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) +monotype t = Monotype <$> ABT.visit isMono t where + isMono (Forall' _) = Just Nothing + isMono _ = Nothing + +arity :: Type v a -> Int +arity (ForallNamed' _ body) = arity body +arity (Arrow' _ o) = 1 + arity o +arity (Ann' a _) = arity a +arity _ = 0 + +-- some smart patterns +pattern Ref' r <- ABT.Tm' (Ref r) +pattern Arrow' i o <- ABT.Tm' (Arrow i o) +pattern Arrow'' i es o <- Arrow' i (Effect'' es o) +pattern Arrows' spine <- (unArrows -> Just spine) +pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) +pattern Ann' t k <- ABT.Tm' (Ann t k) +pattern App' f x <- ABT.Tm' (App f x) +pattern Apps' f args <- (unApps -> Just (f, args)) +pattern Pure' t <- (unPure -> Just t) +pattern Effects' es <- ABT.Tm' (Effects es) +-- Effect1' must match at least one effect +pattern Effect1' e t <- ABT.Tm' (Effect e t) +pattern Effect' es t <- (unEffects1 -> Just (es, t)) +pattern Effect'' es t <- (unEffect0 -> (es, t)) +-- Effect0' may match zero effects +pattern Effect0' es t <- (unEffect0 -> (es, t)) +pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) +pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) +pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) +pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) +pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst + +unPure :: Ord v => Type v a -> Maybe (Type v a) +unPure (Effect'' [] t) = Just t +unPure (Effect'' _ _) = Nothing +unPure t = Just t + +unArrows :: Type v a -> Maybe [Type v a] +unArrows t = + case go t of [_] -> Nothing; l -> Just l + where go (Arrow' i o) = i : go o + go o = [o] + +unEffectfulArrows + :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) +unEffectfulArrows t = case t of + Arrow' i o -> Just (i, go o) + _ -> Nothing + where + go (Effect1' (Effects' es) (Arrow' i o)) = + (Just $ es >>= flattenEffects, i) : go o + go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] + go (Arrow' i o) = (Nothing, i) : go o + go t = [(Nothing, t)] + +unApps :: Type v a -> Maybe (Type v a, [Type v a]) +unApps t = case go t [] of + [] -> Nothing + [ _ ] -> Nothing + f : args -> Just (f, args) + where + go (App' i o) acc = go i (o : acc) + go fn args = fn : args + +unIntroOuters :: Type v a -> Maybe ([v], Type v a) +unIntroOuters t = go t [] + where go (IntroOuterNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just (reverse vs, body) + +-- Most code doesn't care about `introOuter` binders and is fine dealing with the +-- these outer variable references as free variables. This function strips out +-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. +stripIntroOuters :: Type v a -> Type v a +stripIntroOuters t = case unIntroOuters t of + Just (_, t) -> t + Nothing -> t + +unForalls :: Type v a -> Maybe ([v], Type v a) +unForalls t = go t [] + where go (ForallNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just(reverse vs, body) + +unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) +unEffect0 (Effect1' e a) = (flattenEffects e, a) +unEffect0 t = ([], t) + +unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) +unEffects1 (Effect1' (Effects' es) a) = Just (es, a) +unEffects1 _ = Nothing + +-- | True if the given type is a function, possibly quantified +isArrow :: ABT.Var v => Type v a -> Bool +isArrow (ForallNamed' _ t) = isArrow t +isArrow (Arrow' _ _) = True +isArrow _ = False + +-- some smart constructors + +ref :: Ord v => a -> Reference -> Type v a +ref a = ABT.tm' a . Ref + +refId :: Ord v => a -> Reference.Id -> Type v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Type v a +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 r a = ref a r + +intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference +intRef = Reference.Builtin "Int" +natRef = Reference.Builtin "Nat" +floatRef = Reference.Builtin "Float" +booleanRef = Reference.Builtin "Boolean" +textRef = Reference.Builtin "Text" +charRef = Reference.Builtin "Char" +listRef = Reference.Builtin "Sequence" +bytesRef = Reference.Builtin "Bytes" +effectRef = Reference.Builtin "Effect" +termLinkRef = Reference.Builtin "Link.Term" +typeLinkRef = Reference.Builtin "Link.Type" + +builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference +builtinIORef = Reference.Builtin "IO" +fileHandleRef = Reference.Builtin "Handle" +filePathRef = Reference.Builtin "FilePath" +threadIdRef = Reference.Builtin "ThreadId" +socketRef = Reference.Builtin "Socket" + +mvarRef, tvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +tvarRef = Reference.Builtin "TVar" + +tlsRef :: Reference +tlsRef = Reference.Builtin "Tls" + +stmRef :: Reference +stmRef = Reference.Builtin "STM" + +tlsClientConfigRef :: Reference +tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" + +tlsServerConfigRef :: Reference +tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" + +tlsSignedCertRef :: Reference +tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" + +tlsPrivateKeyRef :: Reference +tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" + +tlsCipherRef :: Reference +tlsCipherRef = Reference.Builtin "Tls.Cipher" + +tlsVersionRef :: Reference +tlsVersionRef = Reference.Builtin "Tls.Version" + +hashAlgorithmRef :: Reference +hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" + +codeRef, valueRef :: Reference +codeRef = Reference.Builtin "Code" +valueRef = Reference.Builtin "Value" + +anyRef :: Reference +anyRef = Reference.Builtin "Any" + +any :: Ord v => a -> Type v a +any a = ref a anyRef + +builtin :: Ord v => a -> Text -> Type v a +builtin a = ref a . Reference.Builtin + +int :: Ord v => a -> Type v a +int a = ref a intRef + +nat :: Ord v => a -> Type v a +nat a = ref a natRef + +float :: Ord v => a -> Type v a +float a = ref a floatRef + +boolean :: Ord v => a -> Type v a +boolean a = ref a booleanRef + +text :: Ord v => a -> Type v a +text a = ref a textRef + +char :: Ord v => a -> Type v a +char a = ref a charRef + +fileHandle :: Ord v => a -> Type v a +fileHandle a = ref a fileHandleRef + +threadId :: Ord v => a -> Type v a +threadId a = ref a threadIdRef + +builtinIO :: Ord v => a -> Type v a +builtinIO a = ref a builtinIORef + +socket :: Ord v => a -> Type v a +socket a = ref a socketRef + +list :: Ord v => a -> Type v a +list a = ref a listRef + +bytes :: Ord v => a -> Type v a +bytes a = ref a bytesRef + +effectType :: Ord v => a -> Type v a +effectType a = ref a $ effectRef + +code, value :: Ord v => a -> Type v a +code a = ref a codeRef +value a = ref a valueRef + +app :: Ord v => a -> Type v a -> Type v a -> Type v a +app a f arg = ABT.tm' a (App f arg) + +-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one +-- meant for `app (f x) y` +apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a +apps = foldl' go where go f (a, t) = app a f t + +app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a +app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg + +apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a +apps' = foldl app' + +arrow :: Ord v => a -> Type v a -> Type v a -> Type v a +arrow a i o = ABT.tm' a (Arrow i o) + +arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a +arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o + +ann :: Ord v => a -> Type v a -> K.Kind -> Type v a +ann a e t = ABT.tm' a (Ann e t) + +forall :: Ord v => a -> v -> Type v a -> Type v a +forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) + +introOuter :: Ord v => a -> v -> Type v a -> Type v a +introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) + +iff :: Var v => Type v () +iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a + where aa = Var.named "a" + a = var () aa + f x = ((), x) + +iff' :: Var v => a -> Type v a +iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +iff2 :: Var v => a -> Type v a +iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +andor :: Ord v => Type v () +andor = arrows (f <$> [boolean(), boolean()]) $ boolean() + where f x = ((), x) + +andor' :: Ord v => a -> Type v a +andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a + where f x = (a, x) + +var :: Ord v => a -> v -> Type v a +var = ABT.annotatedVar + +v' :: Var v => Text -> Type v () +v' s = ABT.var (Var.named s) + +-- Like `v'`, but creates an annotated variable given an annotation +av' :: Var v => a -> Text -> Type v a +av' a s = ABT.annotatedVar a (Var.named s) + +forall' :: Var v => a -> [Text] -> Type v a -> Type v a +forall' a vs body = foldr (forall a) body (Var.named <$> vs) + +foralls :: Ord v => a -> [v] -> Type v a -> Type v a +foralls a vs body = foldr (forall a) body vs + +-- Note: `a -> b -> c` parses as `a -> (b -> c)` +-- the annotation associated with `b` will be the annotation for the `b -> c` +-- node +arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a +arrows ts result = foldr go result ts where + go = uncurry arrow + +-- The types of effectful computations +effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a +effect a es (Effect1' fs t) = + let es' = (es >>= flattenEffects) ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) + +effects :: Ord v => a -> [Type v a] -> Type v a +effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) + +effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a +effect1 a es (Effect1' fs t) = + let es' = flattenEffects es ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect1 a es t = ABT.tm' a (Effect es t) + +flattenEffects :: Type v a -> [Type v a] +flattenEffects (Effects' es) = es >>= flattenEffects +flattenEffects es = [es] + +-- The types of first-class effect values +-- which get deconstructed in effect handlers. +effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a +effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] + +-- Strips effects from a type. E.g. `{e} a` becomes `a`. +stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) +stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) +stripEffect t = ([], t) + +-- The type of the flipped function application operator: +-- `(a -> (a -> b) -> b)` +flipApply :: Var v => Type v () -> Type v () +flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) + where b = ABT.fresh t (Var.named "b") + +generalize' :: Var v => Var.Type -> Type v a -> Type v a +generalize' k t = generalize vsk t where + vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] + +-- | Bind the given variables with an outer `forall`, if they are used in `t`. +generalize :: Ord v => [v] -> Type v a -> Type v a +generalize vs t = foldr f t vs + where + f v t = + if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + +unforall :: Type v a -> Type v a +unforall (ForallsNamed' _ t) = t +unforall t = t + +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 t = Set.fromList . Writer.execWriter $ ABT.visit' f t + where f t@(Ref r) = Writer.tell [r] $> t + f t = pure t + +updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a +updateDependencies typeUpdates = ABT.rebuildUp go + where + go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) + go f = f + +usesEffects :: Ord v => Type v a -> Bool +usesEffects t = getAny . getConst $ ABT.visit go t where + go (Effect1' _ _) = Just (Const (Any True)) + go _ = Nothing + +-- Returns free effect variables in the given type, for instance, in: +-- +-- βˆ€ e3 . a ->{e,e2} b ->{e3} c +-- +-- This function would return the set {e, e2}, but not `e3` since `e3` +-- is bound by the enclosing forall. +freeEffectVars :: Ord v => Type v a -> Set v +freeEffectVars t = + Set.fromList . join . runIdentity $ + ABT.foreachSubterm go (snd <$> ABT.annotateBound t) + where + go t@(Effects' es) = + let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go t@(Effect1' e _) = + let frees = Set.fromList [ v | Var' v <- flattenEffects e ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go _ = pure [] + +-- Converts all unadorned arrows in a type to have fresh +-- existential ability requirements. For example: +-- +-- (a -> b) -> [a] -> [b] +-- +-- Becomes +-- +-- (a ->{e1} b) ->{e2} [a] ->{e3} [b] +existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) +existentializeArrows newVar t = ABT.visit go t + where + go t@(Arrow' a b) = case b of + -- If an arrow already has attached abilities, + -- leave it alone. Ex: `a ->{e} b` is kept as is. + Effect1' _ _ -> Just $ do + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + pure $ arrow (ABT.annotation t) a b + -- For unadorned arrows, make up a fresh variable. + -- So `a -> b` becomes `a ->{e} b`, using the + -- `newVar` variable generator. + _ -> Just $ do + e <- newVar + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + let ann = ABT.annotation t + pure $ arrow ann a (effect ann [var ann e] b) + go _ = Nothing + +purifyArrows :: (Ord v) => Type v a -> Type v a +purifyArrows = ABT.visitPure go + where + go t@(Arrow' a b) = case b of + Effect1' _ _ -> Nothing + _ -> Just $ arrow ann a (effect ann [] b) + where ann = ABT.annotation t + go _ = Nothing + +-- Remove free effect variables from the type that are in the set +removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a +removeEffectVars removals t = + let z = effects () [] + t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t + -- leave explicitly empty `{}` alone + removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) + removeEmpty t@(Effect1' e v) = + case flattenEffects e of + [] -> Just (ABT.visitPure removeEmpty v) + es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) + removeEmpty t@(Effects' es) = + Just $ effects (ABT.annotation t) (es >>= flattenEffects) + removeEmpty _ = Nothing + in ABT.visitPure removeEmpty t' + +-- Remove all effect variables from the type. +-- Used for type-based search, we apply this transformation to both the +-- indexed type and the query type, so the user can supply `a -> b` that will +-- match `a ->{e} b` (but not `a ->{IO} b`). +removeAllEffectVars :: ABT.Var v => Type v a -> Type v a +removeAllEffectVars t = let + allEffectVars = foldMap go (ABT.subterms t) + go (Effects' vs) = Set.fromList [ v | Var' v <- vs] + go (Effect1' (Var' v) _) = Set.singleton v + go _ = mempty + (vs, tu) = unforall' t + in generalize vs (removeEffectVars allEffectVars tu) + +removePureEffects :: ABT.Var v => Type v a -> Type v a +removePureEffects t | not Settings.removePureEffects = t + | otherwise = + generalize vs $ removeEffectVars (Set.filter isPure fvs) tu + where + (vs, tu) = unforall' t + fvs = freeEffectVars tu `Set.difference` ABT.freeVars t + -- If an effect variable is mentioned only once, it is on + -- an arrow `a ->{e} b`. Generalizing this to + -- `βˆ€ e . a ->{e} b` gives us the pure arrow `a -> b`. + isPure v = ABT.occurrences v tu <= 1 + +editFunctionResult + :: forall v a + . Ord v + => (Type v a -> Type v a) + -> Type v a + -> Type v a +editFunctionResult f = go + where + go :: Type v a -> Type v a + go (ABT.Term s a t) = case t of + ABT.Tm (Forall t) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t + ABT.Tm (Arrow i o) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o + ABT.Abs v r -> + (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r + _ -> f (ABT.Term s a t) + +functionResult :: Type v a -> Maybe (Type v a) +functionResult = go False + where + go inArr (ForallNamed' _ body) = go inArr body + go _inArr (Arrow' _i o ) = go True o + go inArr t = if inArr then Just t else Nothing + + +-- | Bind all free variables (not in `except`) that start with a lowercase +-- letter and are unqualified with an outer `forall`. +-- `a -> a` becomes `βˆ€ a . a -> a` +-- `B -> B` becomes `B -> B` (not changed) +-- `.foo -> .foo` becomes `.foo -> .foo` (not changed) +-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) +generalizeLowercase :: Var v => Set v -> Type v a -> Type v a +generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars + where + vars = + [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] + +-- Convert all free variables in `allowed` to variables bound by an `introOuter`. +freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a +freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars + where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed + +-- | This function removes all variable shadowing from the types and reduces +-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing +-- two different types. +cleanupVars :: Var v => [Type v a] -> [Type v a] +cleanupVars ts | not Settings.cleanupTypes = ts +cleanupVars ts = let + changedVars = cleanupVarsMap ts + in cleanupVars1' changedVars <$> ts + +-- Compute a variable replacement map from a collection of types, which +-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids +-- for multiple related types, like when reporting a type error. +cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v +cleanupVarsMap ts = let + varsByName = foldl' step Map.empty (ts >>= ABT.allVars) + step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m + changedVars = Map.fromList [ (v, Var.freshenId i v) + | (_, vs) <- Map.toList varsByName + , (v,i) <- nubOrd vs `zip` [0..]] + in changedVars + +cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a +cleanupVars1' = ABT.changeVars + +-- | This function removes all variable shadowing from the type and reduces +-- fresh ids to the minimum possible to avoid ambiguity. +cleanupVars1 :: Var v => Type v a -> Type v a +cleanupVars1 t | not Settings.cleanupTypes = t +cleanupVars1 t = let [t'] = cleanupVars [t] in t' + +-- This removes duplicates and normalizes the order of ability lists +cleanupAbilityLists :: Var v => Type v a -> Type v a +cleanupAbilityLists = ABT.visitPure go + where + -- leave explicitly empty `{}` alone + go (Effect1' (Effects' []) _v) = Nothing + go t@(Effect1' e v) = + let es = Set.toList . Set.fromList $ flattenEffects e + in case es of + [] -> Just (ABT.visitPure go v) + _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) + go _ = Nothing + +cleanups :: Var v => [Type v a] -> [Type v a] +cleanups ts = cleanupVars $ map cleanupAbilityLists ts + +cleanup :: Var v => Type v a -> Type v a +cleanup t | not Settings.cleanupTypes = t +cleanup t = cleanupVars1 . cleanupAbilityLists $ t + +toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference (Ref' r) = r +-- a bit of normalization - any unused type parameters aren't part of the hash +toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +toReference t = Reference.Derived (ABT.hash t) 0 1 + +toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions ty = + let (vs, _) = unforall' ty + gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty + in Set.fromList $ toReference . gen <$> ABT.subterms ty + +hashComponents + :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +instance Hashable1 F where + hash1 hashCycle hash e = + let + (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `0` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 0 : case e of + Ref r -> [tag 0, Hashable.accumulateToken r] + Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] + App a b -> [tag 2, hashed (hash a), hashed (hash b) ] + Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] + -- Example: + -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as + -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from + -- c) {Remote, Abort} (() -> {Abort} ()) + Effects es -> let + (hs, _) = hashCycle es + in tag 4 : map hashed hs + Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] + Forall a -> [tag 6, hashed (hash a)] + IntroOuter a -> [tag 7, hashed (hash a)] + +instance Show a => Show (F a) where + showsPrec = go where + go _ (Ref r) = shows r + go p (Arrow i o) = + showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o + go p (Ann t k) = + showParen (p > 1) $ shows t <> s":" <> shows k + go p (App f x) = + showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x + go p (Effects es) = showParen (p > 0) $ + s"{" <> shows es <> s"}" + go p (Effect e t) = showParen (p > 0) $ + showParen True $ shows e <> s" " <> showsPrec p t + go p (Forall body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"βˆ€ " <> shows body + go p (IntroOuter body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"outer " <> shows body + (<>) = (.) + s = showString diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs new file mode 100644 index 0000000000..8f642ab84f --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Convert + ( ResolutionResult, + hashDecls, + hashClosedTerm, + hashTermComponents, + hashTypeComponents, + typeToReference, + typeToReferenceMentions, + ) +where + +import Control.Lens (over, _3) +import qualified Control.Lens as Lens +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import qualified Unison.DataDeclaration as Memory.DD +import qualified Unison.Hashing.V2.DataDeclaration as Hashing.DD +import qualified Unison.Hashing.V2.Pattern as Hashing.Pattern +import qualified Unison.Hashing.V2.Reference as Hashing.Reference +import qualified Unison.Hashing.V2.Referent as Hashing.Referent +import qualified Unison.Hashing.V2.Term as Hashing.Term +import qualified Unison.Hashing.V2.Type as Hashing.Type +import Unison.Names.ResolutionResult (ResolutionResult) +import qualified Unison.Pattern as Memory.Pattern +import qualified Unison.Reference as Memory.Reference +import qualified Unison.Referent as Memory.Referent +import qualified Unison.Term as Memory.Term +import qualified Unison.Type as Memory.Type +import Unison.Var (Var) + +typeToReference :: Var v => Memory.Type.Type v a -> Memory.Reference.Reference +typeToReference = h2mReference . Hashing.Type.toReference . m2hType + +typeToReferenceMentions :: Var v => Memory.Type.Type v a -> Set Memory.Reference.Reference +typeToReferenceMentions = Set.map h2mReference . Hashing.Type.toReferenceMentions . m2hType + +hashTypeComponents :: Var v => Map v (Memory.Type.Type v a) -> Map v (Memory.Reference.Id, Memory.Type.Type v a) +hashTypeComponents = fmap h2mTypeResult . Hashing.Type.hashComponents . fmap m2hType + where + h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) + h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp) + +hashTermComponents :: Var v => Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a) +hashTermComponents = fmap h2mTermResult . Hashing.Term.hashComponents . fmap m2hTerm + where + h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a) + h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm) + +hashClosedTerm :: Var v => Memory.Term.Term v a -> Memory.Reference.Id +hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . m2hTerm + +m2hTerm :: Ord v => Memory.Term.Term v a -> Hashing.Term.Term v a +m2hTerm = ABT.transform \case + Memory.Term.Int i -> Hashing.Term.Int i + Memory.Term.Nat n -> Hashing.Term.Nat n + Memory.Term.Float d -> Hashing.Term.Float d + Memory.Term.Boolean b -> Hashing.Term.Boolean b + Memory.Term.Text t -> Hashing.Term.Text t + Memory.Term.Char c -> Hashing.Term.Char c + Memory.Term.Blank b -> Hashing.Term.Blank b + Memory.Term.Ref r -> Hashing.Term.Ref (m2hReference r) + Memory.Term.Constructor r i -> Hashing.Term.Constructor (m2hReference r) i + Memory.Term.Request r i -> Hashing.Term.Request (m2hReference r) i + Memory.Term.Handle x y -> Hashing.Term.Handle x y + Memory.Term.App f x -> Hashing.Term.App f x + Memory.Term.Ann e t -> Hashing.Term.Ann e (m2hType t) + Memory.Term.List as -> Hashing.Term.List as + Memory.Term.And p q -> Hashing.Term.And p q + Memory.Term.If c t f -> Hashing.Term.If c t f + Memory.Term.Or p q -> Hashing.Term.Or p q + Memory.Term.Lam a -> Hashing.Term.Lam a + Memory.Term.LetRec isTop bs body -> Hashing.Term.LetRec isTop bs body + Memory.Term.Let isTop b body -> Hashing.Term.Let isTop b body + Memory.Term.Match scr cases -> Hashing.Term.Match scr (fmap m2hMatchCase cases) + Memory.Term.TermLink r -> Hashing.Term.TermLink (m2hReferent r) + Memory.Term.TypeLink r -> Hashing.Term.TypeLink (m2hReference r) + +m2hMatchCase :: Memory.Term.MatchCase a a1 -> Hashing.Term.MatchCase a a1 +m2hMatchCase (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase (m2hPattern pat) m_a1 a1 + +m2hPattern :: Memory.Pattern.Pattern a -> Hashing.Pattern.Pattern a +m2hPattern = \case + Memory.Pattern.Unbound loc -> Hashing.Pattern.Unbound loc + Memory.Pattern.Var loc -> Hashing.Pattern.Var loc + Memory.Pattern.Boolean loc b -> Hashing.Pattern.Boolean loc b + Memory.Pattern.Int loc i -> Hashing.Pattern.Int loc i + Memory.Pattern.Nat loc n -> Hashing.Pattern.Nat loc n + Memory.Pattern.Float loc f -> Hashing.Pattern.Float loc f + Memory.Pattern.Text loc t -> Hashing.Pattern.Text loc t + Memory.Pattern.Char loc c -> Hashing.Pattern.Char loc c + Memory.Pattern.Constructor loc r i ps -> Hashing.Pattern.Constructor loc (m2hReference r) i (fmap m2hPattern ps) + Memory.Pattern.As loc p -> Hashing.Pattern.As loc (m2hPattern p) + Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc (m2hPattern p) + Memory.Pattern.EffectBind loc r i ps k -> Hashing.Pattern.EffectBind loc (m2hReference r) i (fmap m2hPattern ps) (m2hPattern k) + Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc (fmap m2hPattern ps) + Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc (m2hPattern l) (m2hSequenceOp op) (m2hPattern r) + +m2hSequenceOp :: Memory.Pattern.SeqOp -> Hashing.Pattern.SeqOp +m2hSequenceOp = \case + Memory.Pattern.Cons -> Hashing.Pattern.Cons + Memory.Pattern.Snoc -> Hashing.Pattern.Snoc + Memory.Pattern.Concat -> Hashing.Pattern.Concat + +m2hReferent :: Memory.Referent.Referent -> Hashing.Referent.Referent +m2hReferent = \case + Memory.Referent.Ref ref -> Hashing.Referent.Ref (m2hReference ref) + Memory.Referent.Con ref n ct -> Hashing.Referent.Con (m2hReference ref) n ct + +h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a +h2mTerm = ABT.transform \case + Hashing.Term.Int i -> Memory.Term.Int i + Hashing.Term.Nat n -> Memory.Term.Nat n + Hashing.Term.Float d -> Memory.Term.Float d + Hashing.Term.Boolean b -> Memory.Term.Boolean b + Hashing.Term.Text t -> Memory.Term.Text t + Hashing.Term.Char c -> Memory.Term.Char c + Hashing.Term.Blank b -> Memory.Term.Blank b + Hashing.Term.Ref r -> Memory.Term.Ref (h2mReference r) + Hashing.Term.Constructor r i -> Memory.Term.Constructor (h2mReference r) i + Hashing.Term.Request r i -> Memory.Term.Request (h2mReference r) i + Hashing.Term.Handle x y -> Memory.Term.Handle x y + Hashing.Term.App f x -> Memory.Term.App f x + Hashing.Term.Ann e t -> Memory.Term.Ann e (h2mType t) + Hashing.Term.List as -> Memory.Term.List as + Hashing.Term.If c t f -> Memory.Term.If c t f + Hashing.Term.And p q -> Memory.Term.And p q + Hashing.Term.Or p q -> Memory.Term.Or p q + Hashing.Term.Lam a -> Memory.Term.Lam a + Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body + Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body + Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases) + Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent r) + Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r) + +h2mMatchCase :: Hashing.Term.MatchCase a b -> Memory.Term.MatchCase a b +h2mMatchCase (Hashing.Term.MatchCase pat m_b b) = Memory.Term.MatchCase (h2mPattern pat) m_b b + +h2mPattern :: Hashing.Pattern.Pattern a -> Memory.Pattern.Pattern a +h2mPattern = \case + Hashing.Pattern.Unbound loc -> Memory.Pattern.Unbound loc + Hashing.Pattern.Var loc -> Memory.Pattern.Var loc + Hashing.Pattern.Boolean loc b -> Memory.Pattern.Boolean loc b + Hashing.Pattern.Int loc i -> Memory.Pattern.Int loc i + Hashing.Pattern.Nat loc n -> Memory.Pattern.Nat loc n + Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f + Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t + Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c + Hashing.Pattern.Constructor loc r i ps -> Memory.Pattern.Constructor loc (h2mReference r) i (h2mPattern <$> ps) + Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p) + Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p) + Hashing.Pattern.EffectBind loc r i ps k -> Memory.Pattern.EffectBind loc (h2mReference r) i (h2mPattern <$> ps) (h2mPattern k) + Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps) + Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r) + +h2mSequenceOp :: Hashing.Pattern.SeqOp -> Memory.Pattern.SeqOp +h2mSequenceOp = \case + Hashing.Pattern.Cons -> Memory.Pattern.Cons + Hashing.Pattern.Snoc -> Memory.Pattern.Snoc + Hashing.Pattern.Concat -> Memory.Pattern.Concat + +h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent +h2mReferent = \case + Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref) + Hashing.Referent.Con ref n ct -> Memory.Referent.Con (h2mReference ref) n ct + +hashDecls :: + Var v => + Map v (Memory.DD.DataDeclaration v a) -> + ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] +hashDecls memDecls = do + let hashingDecls = fmap m2hDecl memDecls + hashingResult <- Hashing.DD.hashDecls hashingDecls + pure $ map h2mDeclResult hashingResult + where + h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) + h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) + +m2hDecl :: Ord v => Memory.DD.DataDeclaration v a -> Hashing.DD.DataDeclaration v a +m2hDecl (Memory.DD.DataDeclaration mod ann bound ctors) = + Hashing.DD.DataDeclaration (m2hModifier mod) ann bound $ fmap (Lens.over _3 m2hType) ctors + +m2hType :: Ord v => Memory.Type.Type v a -> Hashing.Type.Type v a +m2hType = ABT.transform \case + Memory.Type.Ref ref -> Hashing.Type.Ref (m2hReference ref) + Memory.Type.Arrow a1 a1' -> Hashing.Type.Arrow a1 a1' + Memory.Type.Ann a1 ki -> Hashing.Type.Ann a1 ki + Memory.Type.App a1 a1' -> Hashing.Type.App a1 a1' + Memory.Type.Effect a1 a1' -> Hashing.Type.Effect a1 a1' + Memory.Type.Effects a1s -> Hashing.Type.Effects a1s + Memory.Type.Forall a1 -> Hashing.Type.Forall a1 + Memory.Type.IntroOuter a1 -> Hashing.Type.IntroOuter a1 + +m2hReference :: Memory.Reference.Reference -> Hashing.Reference.Reference +m2hReference = \case + Memory.Reference.Builtin t -> Hashing.Reference.Builtin t + Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId (m2hReferenceId d) + +m2hReferenceId :: Memory.Reference.Id -> Hashing.Reference.Id +m2hReferenceId (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i _n + +h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier +h2mModifier = \case + Hashing.DD.Structural -> Memory.DD.Structural + Hashing.DD.Unique text -> Memory.DD.Unique text + +m2hModifier :: Memory.DD.Modifier -> Hashing.DD.Modifier +m2hModifier = \case + Memory.DD.Structural -> Hashing.DD.Structural + Memory.DD.Unique text -> Hashing.DD.Unique text + +h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a +h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = + Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) + +h2mType :: Ord v => Hashing.Type.Type v a -> Memory.Type.Type v a +h2mType = ABT.transform \case + Hashing.Type.Ref ref -> Memory.Type.Ref (h2mReference ref) + Hashing.Type.Arrow a1 a1' -> Memory.Type.Arrow a1 a1' + Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 ki + Hashing.Type.App a1 a1' -> Memory.Type.App a1 a1' + Hashing.Type.Effect a1 a1' -> Memory.Type.Effect a1 a1' + Hashing.Type.Effects a1s -> Memory.Type.Effects a1s + Hashing.Type.Forall a1 -> Memory.Type.Forall a1 + Hashing.Type.IntroOuter a1 -> Memory.Type.IntroOuter a1 + +h2mReference :: Hashing.Reference.Reference -> Memory.Reference.Reference +h2mReference = \case + Hashing.Reference.Builtin t -> Memory.Reference.Builtin t + Hashing.Reference.DerivedId d -> Memory.Reference.DerivedId (h2mReferenceId d) + +h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id +h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n diff --git a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs new file mode 100644 index 0000000000..eab303bcb6 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + Modifier (..), + asDataDecl, + constructorType, + constructorTypes, + declDependencies, + dependencies, + bindReferences, + hashDecls, + ) +where + +import Control.Lens (over, _3) +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import Unison.Var (Var) +import qualified Unison.ABT as ABT +import qualified Unison.ConstructorType as CT +import Unison.Hash (Hash) +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as Reference.Util +import Unison.Hashing.V2.Type (Type) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Prelude +-- import qualified Unison.Referent as Referent +-- import qualified Unison.Referent' as Referent' +import Prelude hiding (cycle) + +type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) + +data DeclOrBuiltin v a + = Builtin CT.ConstructorType + | Decl (Decl v a) + deriving (Eq, Show) + +asDataDecl :: Decl v a -> DataDeclaration v a +asDataDecl = either toDataDecl id + +declDependencies :: Ord v => Decl v a -> Set Reference +declDependencies = either (dependencies . toDataDecl) dependencies + +constructorType :: Decl v a -> CT.ConstructorType +constructorType = \case + Left {} -> CT.Effect + Right {} -> CT.Data + +data Modifier = Structural | Unique Text -- | Opaque (Set Reference) + deriving (Eq, Ord, Show) + +data DataDeclaration v a = DataDeclaration + { modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] + } + deriving (Eq, Show, Functor) + +newtype EffectDeclaration v a = EffectDeclaration + { toDataDecl :: DataDeclaration v a + } + deriving (Eq, Show, Functor) + +constructorTypes :: DataDeclaration v a -> [Type v a] +constructorTypes = (snd <$>) . constructors + +constructors :: DataDeclaration v a -> [(v, Type v a)] +constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] + +dependencies :: Ord v => DataDeclaration v a -> Set Reference +dependencies dd = + Set.unions (Type.dependencies <$> constructorTypes dd) + +toABT :: Var v => DataDeclaration v () -> ABT.Term F v () +toABT dd = ABT.tm $ Modified (modifier dd) dd' + where + dd' = ABT.absChain (bound dd) $ ABT.cycle + (ABT.absChain + (fst <$> constructors dd) + (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) + +-- Implementation detail of `hashDecls`, works with unannotated data decls +hashDecls0 :: (Eq v, Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] +hashDecls0 decls = + let abts = toABT <$> decls + ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) + cs = Reference.Util.hashComponents ref abts + in [(v, r) | (v, (r, _)) <- Map.toList cs] + +-- | compute the hashes of these user defined types and update any free vars +-- corresponding to these decls with the resulting hashes +-- +-- data List a = Nil | Cons a (List a) +-- becomes something like +-- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) +-- +-- NOTE: technical limitation, this implementation gives diff results if ctors +-- have the same FQN as one of the types. TODO: assert this and bomb if not +-- satisfied, or else do local mangling and unmangling to ensure this doesn't +-- affect the hash. +hashDecls :: + (Eq v, Var v, Show v) => + Map v (DataDeclaration v a) -> + Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] +hashDecls decls = do + -- todo: make sure all other external references are resolved before calling this + let varToRef = hashDecls0 (void <$> decls) + varToRef' = second Reference.DerivedId <$> varToRef + decls' = bindTypes <$> decls + bindTypes dd = dd {constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd} + typeReferences = Map.fromList (first Name.fromVar <$> varToRef') + -- normalize the order of the constructors based on a hash of their types + sortCtors dd = dd {constructors' = sortOn hash3 $ constructors' dd} + hash3 (_, _, typ) = ABT.hash typ :: Hash + decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' + pure [(v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls']] + +bindReferences :: + Var v => + Set v -> + Map Name.Name Reference -> + DataDeclaration v a -> + Names.ResolutionResult v a (DataDeclaration v a) +bindReferences keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.bindReferences keepFree names ty + pure $ DataDeclaration m a bound constructors + +data F a + = Type (Type.F a) + | LetRec [a] a + | Constructors [a] + | Modified Modifier a + deriving (Functor, Foldable, Show, Show1) + +instance Hashable1 F where + hash1 hashCycle hash e = + let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + in -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + Hashable.accumulate $ + tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +instance Hashable.Hashable Modifier where + tokens Structural = [Hashable.Tag 0] + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs new file mode 100644 index 0000000000..8a00577122 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V2.LabeledDependency + ( derivedTerm + , derivedType + , termRef + , typeRef + , referent + , dataConstructor + , effectConstructor + , fold + , referents + , toReference + , LabeledDependency + , partition + ) where + +import Unison.Prelude hiding (fold) + +import qualified Data.Set as Set +import Unison.Hashing.V2.Reference (Id, Reference (DerivedId)) +import Unison.Hashing.V2.Referent (ConstructorId, Referent, pattern Con, pattern Ref) +import Unison.ConstructorType (ConstructorType (Data, Effect)) + +-- dumb constructor name is private +newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) + +derivedType, derivedTerm :: Id -> LabeledDependency +typeRef, termRef :: Reference -> LabeledDependency +referent :: Referent -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency + +derivedType = X . Left . DerivedId +derivedTerm = X . Right . Ref . DerivedId +typeRef = X . Left +termRef = X . Right . Ref +referent = X . Right +dataConstructor r cid = X . Right $ Con r cid Data +effectConstructor r cid = X . Right $ Con r cid Effect + +referents :: Foldable f => f Referent -> Set LabeledDependency +referents rs = Set.fromList (map referent $ toList rs) + +fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a +fold f g (X e) = either f g e + +partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) +partition = partitionEithers . map (\(X e) -> e) . toList + +-- | Left TypeRef | Right TermRef +toReference :: LabeledDependency -> Either Reference Reference +toReference = \case + X (Left r) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs new file mode 100644 index 0000000000..8a766f8b17 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs @@ -0,0 +1,156 @@ +{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} + +module Unison.Hashing.V2.Pattern where + +import Unison.Prelude + +import Data.Foldable as Foldable hiding (foldMap') +import Data.List (intercalate) +import qualified Data.Set as Set +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.Hashable as H + +type ConstructorId = Int + +data Pattern loc + = Unbound loc + | Var loc + | Boolean loc !Bool + | Int loc !Int64 + | Nat loc !Word64 + | Float loc !Double + | Text loc !Text + | Char loc !Char + | Constructor loc !Reference !Int [Pattern loc] + | As loc (Pattern loc) + | EffectPure loc (Pattern loc) + | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | SequenceLiteral loc [Pattern loc] + | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + deriving (Ord,Generic,Functor,Foldable,Traversable) + +data SeqOp = Cons + | Snoc + | Concat + deriving (Eq, Show, Ord, Generic) + +instance H.Hashable SeqOp where + tokens Cons = [H.Tag 0] + tokens Snoc = [H.Tag 1] + tokens Concat = [H.Tag 2] + +instance Show (Pattern loc) where + show (Unbound _ ) = "Unbound" + show (Var _ ) = "Var" + show (Boolean _ x) = "Boolean " <> show x + show (Int _ x) = "Int " <> show x + show (Nat _ x) = "Nat " <> show x + show (Float _ x) = "Float " <> show x + show (Text _ t) = "Text " <> show t + show (Char _ c) = "Char " <> show c + show (Constructor _ r i ps) = + "Constructor " <> unwords [show r, show i, show ps] + show (As _ p) = "As " <> show p + show (EffectPure _ k) = "EffectPure " <> show k + show (EffectBind _ r i ps k) = + "EffectBind " <> unwords [show r, show i, show ps, show k] + show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) + show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt + +application :: Pattern loc -> Bool +application (Constructor _ _ _ (_ : _)) = True +application _ = False + +loc :: Pattern loc -> loc +loc p = head $ Foldable.toList p + +setLoc :: Pattern loc -> loc -> Pattern loc +setLoc p loc = case p of + EffectBind _ a b c d -> EffectBind loc a b c d + EffectPure _ a -> EffectPure loc a + As _ a -> As loc a + Constructor _ a b c -> Constructor loc a b c + SequenceLiteral _ ps -> SequenceLiteral loc ps + SequenceOp _ ph op pt -> SequenceOp loc ph op pt + x -> fmap (const loc) x + +instance H.Hashable (Pattern p) where + tokens (Unbound _) = [H.Tag 0] + tokens (Var _) = [H.Tag 1] + tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] + tokens (Int _ n) = H.Tag 3 : [H.Int n] + tokens (Nat _ n) = H.Tag 4 : [H.Nat n] + tokens (Float _ f) = H.Tag 5 : H.tokens f + tokens (Constructor _ r n args) = + [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] + tokens (EffectPure _ p) = H.Tag 7 : H.tokens p + tokens (EffectBind _ r n args k) = + [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] + tokens (As _ p) = H.Tag 9 : H.tokens p + tokens (Text _ t) = H.Tag 10 : H.tokens t + tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps + tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r + tokens (Char _ c) = H.Tag 13 : H.tokens c + +instance Eq (Pattern loc) where + Unbound _ == Unbound _ = True + Var _ == Var _ = True + Boolean _ b == Boolean _ b2 = b == b2 + Int _ n == Int _ m = n == m + Nat _ n == Nat _ m = n == m + Float _ f == Float _ g = f == g + Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs + EffectPure _ p == EffectPure _ q = p == q + EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 + As _ p == As _ q = p == q + Text _ t == Text _ t2 = t == t2 + SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 + SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 + _ == _ = False + +foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m +foldMap' f p = case p of + Unbound _ -> f p + Var _ -> f p + Boolean _ _ -> f p + Int _ _ -> f p + Nat _ _ -> f p + Float _ _ -> f p + Text _ _ -> f p + Char _ _ -> f p + Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps + As _ p' -> f p <> foldMap' f p' + EffectPure _ p' -> f p <> foldMap' f p' + EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' + SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps + SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 + +generalizedDependencies + :: Ord r + => (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Pattern loc + -> Set r +generalizedDependencies literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . foldMap' + (\case + Unbound _ -> mempty + Var _ -> mempty + As _ _ -> mempty + Constructor _ r cid _ -> [dataType r, dataConstructor r cid] + EffectPure _ _ -> [effectType Type.effectRef] + EffectBind _ r cid _ _ -> + [effectType Type.effectRef, effectType r, effectConstructor r cid] + SequenceLiteral _ _ -> [literalType Type.listRef] + SequenceOp {} -> [literalType Type.listRef] + Boolean _ _ -> [literalType Type.booleanRef] + Int _ _ -> [literalType Type.intRef] + Nat _ _ -> [literalType Type.natRef] + Float _ _ -> [literalType Type.floatRef] + Text _ _ -> [literalType Type.textRef] + Char _ _ -> [literalType Type.charRef] + ) diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs new file mode 100644 index 0000000000..75e9641bea --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Reference + (Reference, + pattern Builtin, + pattern Derived, + pattern DerivedId, + Id(..), + Pos, + Size, + derivedBase32Hex, + Component, members, + components, + groupByComponent, + componentFor, + unsafeFromText, + idFromText, + isPrefixOf, + fromShortHash, + fromText, + readSuffix, + showShort, + showSuffix, + toId, + toText, + unsafeId, + toShortHash, + idToShortHash) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Unison.Hash as H +import Unison.Hashable as Hashable +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import Data.Char (isDigit) + +-- | Either a builtin or a user defined (hashed) top-level declaration. +-- +-- Used for both terms and types. Doesn't distinguish between them. +-- +-- Other used defined things like local variables don't get @Reference@s. +data Reference + = Builtin Text.Text + -- `Derived` can be part of a strongly connected component. + -- The `Pos` refers to a particular element of the component + -- and the `Size` is the number of elements in the component. + -- Using an ugly name so no one tempted to use this + | DerivedId Id deriving (Eq,Ord,Generic) + +pattern Derived :: H.Hash -> Pos -> Size -> Reference +pattern Derived h i n = DerivedId (Id h i n) + +{-# COMPLETE Builtin, Derived #-} + +-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. +data Id = Id H.Hash Pos Size deriving (Generic) + +unsafeId :: Reference -> Id +unsafeId (Builtin b) = + error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." +unsafeId (DerivedId x) = x + +idToShortHash :: Id -> ShortHash +idToShortHash = toShortHash . DerivedId + +-- todo: move these to ShortHash module? +-- but Show Reference currently depends on SH +toShortHash :: Reference -> ShortHash +toShortHash (Builtin b) = SH.Builtin b +toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing +toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing + where + -- todo: remove `n` parameter; must also update readSuffix + index = Just $ showSuffix i n + +-- toShortHash . fromJust . fromShortHash == id and +-- fromJust . fromShortHash . toShortHash == id +-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it +-- may not be possible to base32Hex decode them. These will return Nothing. +-- Also, ShortHashes that include constructor ids will return Nothing; +-- try Referent.fromShortHash +fromShortHash :: ShortHash -> Maybe Reference +fromShortHash (SH.Builtin b) = Just (Builtin b) +fromShortHash (SH.ShortHash prefix cycle Nothing) = do + h <- H.fromBase32Hex prefix + case cycle of + Nothing -> Just (Derived h 0 1) + Just t -> case Text.splitOn "c" t of + [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) + _ -> Nothing +fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing + +-- (3,10) encoded as "3c10" +-- (0,93) encoded as "0c93" +showSuffix :: Pos -> Size -> Text +showSuffix i n = Text.pack $ show i <> "c" <> show n + +-- todo: don't read or return size; must also update showSuffix and fromText +readSuffix :: Text -> Either String (Pos, Size) +readSuffix t = case Text.breakOn "c" t of + (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> + Right (read (Text.unpack pos), read (Text.unpack size)) + _ -> Left "suffix decoding error" + +isPrefixOf :: ShortHash -> Reference -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +toText :: Reference -> Text +toText = SH.toText . toShortHash + +showShort :: Int -> Reference -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +type Pos = Word64 +type Size = Word64 + +newtype Component = Component { members :: Set Reference } + +-- Gives the component (dependency cycle) that the reference is a part of +componentFor :: Reference -> Component +componentFor b@Builtin {} = Component (Set.singleton b) +componentFor (Derived h _ n) = + Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] + +derivedBase32Hex :: Text -> Pos -> Size -> Reference +derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) + where + msg = error $ "Reference.derivedBase32Hex " <> show h + h = H.fromBase32Hex b32Hex + +unsafeFromText :: Text -> Reference +unsafeFromText = either error id . fromText + +idFromText :: Text -> Maybe Id +idFromText s = case fromText s of + Left _ -> Nothing + Right (Builtin _) -> Nothing + Right (DerivedId id) -> pure id + +toId :: Reference -> Maybe Id +toId (DerivedId id) = Just id +toId Builtin{} = Nothing + +-- examples: +-- `##Text.take` β€” builtins don’t have cycles +-- `#2tWjVAuc7` β€” derived, no cycle +-- `#y9ycWkiC1.y9` β€” derived, part of cycle +-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. +fromText :: Text -> Either String Reference +fromText t = case Text.split (=='#') t of + [_, "", b] -> Right (Builtin b) + [_, h] -> case Text.split (=='.') h of + [hash] -> Right (derivedBase32Hex hash 0 1) + [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix + _ -> bail + _ -> bail + where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t + +component :: H.Hash -> [k] -> [(k, Id)] +component h ks = let + size = fromIntegral (length ks) + in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] + +components :: [(H.Hash, [k])] -> [(k, Id)] +components sccs = uncurry component =<< sccs + +groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] +groupByComponent refs = done $ foldl' insert Map.empty refs + where + insert m (k, r@(Derived h _ _)) = + Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) + insert m (k, r) = + Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) + done m = sortOn snd <$> toList m + +instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId +instance Show Reference where show = SH.toString . SH.take 5 . toShortHash + +instance Hashable.Hashable Reference where + tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] + tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] + +-- | Two references mustn't differ in cycle length only. +instance Eq Id where x == y = compare x y == EQ +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs new file mode 100644 index 0000000000..817da14efe --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs @@ -0,0 +1,19 @@ +module Unison.Hashing.V2.Reference.Util where + +import Unison.Prelude + +import qualified Unison.Hashing.V2.Reference as Reference +import Unison.Hashable (Hashable1) +import Unison.ABT (Var) +import qualified Unison.ABT as ABT +import qualified Data.Map as Map + +hashComponents :: + (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) + => (Reference.Id -> ABT.Term f v ()) + -> Map v (ABT.Term f v a) + -> Map v (Reference.Id, ABT.Term f v a) +hashComponents embedRef tms = + Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) diff --git a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs new file mode 100644 index 0000000000..af9a00fc11 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V2.Referent where + +import Unison.Prelude +import Unison.Referent' ( Referent'(..), toReference' ) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as R +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH + +import Unison.ConstructorType (ConstructorType) +import qualified Unison.ConstructorType as CT + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. +type Referent = Referent' Reference +type ConstructorId = Int +pattern Ref :: Reference -> Referent +pattern Ref r = Ref' r +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent +pattern Con r i t = Con' r i t +{-# COMPLETE Ref, Con #-} + +-- | Cannot be a builtin. +type Id = Referent' R.Id + +-- todo: move these to ShortHash module +toShortHash :: Referent -> ShortHash +toShortHash = \case + Ref r -> R.toShortHash r + Con r i _ -> patternShortHash r i + +toShortHashId :: Id -> ShortHash +toShortHashId = toShortHash . fromId + +-- also used by HashQualified.fromPattern +patternShortHash :: Reference -> ConstructorId -> ShortHash +patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } + +showShort :: Int -> Referent -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +toText :: Referent -> Text +toText = \case + Ref r -> R.toText r + Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) + +ctorTypeText :: CT.ConstructorType -> Text +ctorTypeText CT.Effect = EffectCtor +ctorTypeText CT.Data = DataCtor + +pattern EffectCtor = "a" +pattern DataCtor = "d" + +toString :: Referent -> String +toString = Text.unpack . toText + +isConstructor :: Referent -> Bool +isConstructor Con{} = True +isConstructor _ = False + +toTermReference :: Referent -> Maybe Reference +toTermReference = \case + Ref r -> Just r + _ -> Nothing + +toReference :: Referent -> Reference +toReference = toReference' + +fromId :: Id -> Referent +fromId = fmap R.DerivedId + +toTypeReference :: Referent -> Maybe Reference +toTypeReference = \case + Con r _i _t -> Just r + _ -> Nothing + +isPrefixOf :: ShortHash -> Referent -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +unsafeFromText :: Text -> Referent +unsafeFromText = fromMaybe (error "invalid referent") . fromText + +-- #abc[.xy][#cid] +fromText :: Text -> Maybe Referent +fromText t = either (const Nothing) Just $ + -- if the string has just one hash at the start, it's just a reference + if Text.length refPart == 1 then + Ref <$> R.fromText t + else if Text.all Char.isDigit cidPart then do + r <- R.fromText (Text.dropEnd 1 refPart) + ctorType <- ctorType + let cid = read (Text.unpack cidPart) + pure $ Con r cid ctorType + else + Left ("invalid constructor id: " <> Text.unpack cidPart) + where + ctorType = case Text.take 1 cidPart' of + EffectCtor -> Right CT.Effect + DataCtor -> Right CT.Data + _otherwise -> + Left ("invalid constructor type (expected '" + <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') + refPart = Text.dropWhileEnd (/= '#') t + cidPart' = Text.takeWhileEnd (/= '#') t + cidPart = Text.drop 1 cidPart' + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct diff --git a/parser-typechecker/src/Unison/Hashing/V2/Term.hs b/parser-typechecker/src/Unison/Hashing/V2/Term.hs new file mode 100644 index 0000000000..4d0eeb907a --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Term.hs @@ -0,0 +1,1120 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Term where + +import Unison.Prelude + +import Prelude hiding (and,or) +import Control.Monad.State (evalState) +import qualified Control.Monad.Writer.Strict as Writer +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Sequence as Sequence +import Prelude.Extras (Eq1(..), Show1(..)) +import Text.Show +import qualified Unison.ABT as ABT +import qualified Unison.Blank as B +import qualified Unison.Hash as Hash +import Unison.Hashable (Hashable1, accumulateToken) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V2.Pattern (Pattern) +import qualified Unison.Hashing.V2.Pattern as Pattern +import Unison.Hashing.V2.Reference (Reference, pattern Builtin) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil +import Unison.Hashing.V2.Referent (Referent) +import qualified Unison.Hashing.V2.Referent as Referent +import Unison.Hashing.V2.Type (Type) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Util.List (multimap) +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unsafe.Coerce +import Unison.Symbol (Symbol) +import qualified Unison.Hashing.V2.LabeledDependency as LD +import Unison.Hashing.V2.LabeledDependency (LabeledDependency) + +-- This gets reexported; should maybe live somewhere other than Pattern, though. +type ConstructorId = Pattern.ConstructorId + +data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a + deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) + +-- | Base functor for terms in the Unison language +-- We need `typeVar` because the term and type variables may differ. +data F typeVar typeAnn patternAnn a + = Int Int64 + | Nat Word64 + | Float Double + | Boolean Bool + | Text Text + | Char Char + | Blank (B.Blank typeAnn) + | Ref Reference + -- First argument identifies the data type, + -- second argument identifies the constructor + | Constructor Reference ConstructorId + | Request Reference ConstructorId + | Handle a a + | App a a + | Ann a (Type typeVar typeAnn) + | List (Seq a) + | If a a a + | And a a + | Or a a + | Lam a + -- Note: let rec blocks have an outer ABT.Cycle which introduces as many + -- variables as there are bindings + | LetRec IsTop [a] a + -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + | Let IsTop a a + -- Pattern matching / eliminating data types, example: + -- case x of + -- Just n -> rhs1 + -- Nothing -> rhs2 + -- + -- translates to + -- + -- Match x + -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- , (Constructor 1 [], rhs2) ] + | Match a [MatchCase patternAnn a] + | TermLink Referent + | TypeLink Reference + deriving (Foldable,Functor,Generic,Generic1,Traversable) + +type IsTop = Bool + +-- | Like `Term v`, but with an annotation of type `a` at every level in the tree +type Term v a = Term2 v a a v a +-- | Allow type variables and term variables to differ +type Term' vt v a = Term2 vt a a v a +-- | Allow type variables, term variables, type annotations and term annotations +-- to all differ +type Term2 vt at ap v a = ABT.Term (F vt at ap) v a +-- | Like `Term v a`, but with only () for type and pattern annotations. +type Term3 v a = Term2 v () () v a + +-- | Terms are represented as ABTs over the base functor F, with variables in `v` +type Term0 v = Term v () +-- | Terms with type variables in `vt`, and term variables in `v` +type Term0' vt v = Term' vt v () + +-- Prepare a term for type-directed name resolution by replacing +-- any remaining free variables with blanks to be resolved by TDNR +prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b +prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t + where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = + Just $ resolve (a, bound) a (Text.unpack $ Var.name v) + f _ = Nothing + +amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 +amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) + +patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a +patternMap f = go where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ + MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) + -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a +vmap f = ABT.vmap f . typeMap (ABT.vmap f) + +vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a +vtmap f = typeMap (ABT.vmap f) + +typeMap + :: Ord vt2 + => (Type vt at -> Type vt2 at2) + -> Term2 vt at ap v a + -> Term2 vt2 at2 ap v a +typeMap f = go + where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) + -- Safe since `Ann` is only ctor that has embedded `Type v` arg + -- otherwise we'd have to manually match on every non-`Ann` ctor + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +extraMap' + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> Term2 vt at ap v a + -> Term2 vt' at' ap' v a +extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) + +extraMap + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> F vt at ap a + -> F vt' at' ap' a +extraMap vtf atf apf = \case + Int x -> Int x + Nat x -> Nat x + Float x -> Float x + Boolean x -> Boolean x + Text x -> Text x + Char x -> Char x + Blank x -> Blank (fmap atf x) + Ref x -> Ref x + Constructor x y -> Constructor x y + Request x y -> Request x y + Handle x y -> Handle x y + App x y -> App x y + Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) + List x -> List x + If x y z -> If x y z + And x y -> And x y + Or x y -> Or x y + Lam x -> Lam x + LetRec x y z -> LetRec x y z + Let x y z -> Let x y z + Match tm l -> Match tm (map (matchCaseExtraMap apf) l) + TermLink r -> TermLink r + TypeLink r -> TypeLink r + +matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a +matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y + +unannotate + :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v +unannotate = go + where + go :: Term2 vt at ap v a -> Term0' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v ) = ABT.var v + go (ABT.Tm' f ) = case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + +wrapV :: Ord v => Term v a -> Term (ABT.V v) a +wrapV = vmap ABT.Bound + +-- | All variables mentioned in the given term. +-- Includes both term and type variables, both free and bound. +allVars :: Ord v => Term v a -> Set v +allVars tm = Set.fromList $ + ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] + where + allTypes tm = case tm of + Ann' e tp -> tp : allTypes e + _ -> foldMap allTypes $ ABT.out tm + +freeVars :: Term' vt v a -> Set v +freeVars = ABT.freeVars + +freeTypeVars :: Ord vt => Term' vt v a -> Set vt +freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t + +freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] +freeTypeVarAnnotations e = multimap $ go Set.empty e where + go bound tm = case tm of + Var' _ -> mempty + Ann' e (Type.stripIntroOuters -> t1) -> let + bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs + _ -> bound + in go bound' e <> ABT.freeVarOccurrences bound t1 + ABT.Tm' f -> foldMap (go bound) f + (ABT.out -> ABT.Abs _ body) -> go bound body + (ABT.out -> ABT.Cycle body) -> go bound body + _ -> error "unpossible" + +substTypeVars :: (Ord v, Var vt) + => [(vt, Type vt b)] + -> Term' vt v a + -> Term' vt v a +substTypeVars subs e = foldl' go e subs where + go e (vt, t) = substTypeVar vt t e + +-- Capture-avoiding substitution of a type variable inside a term. This +-- will replace that type variable wherever it appears in type signatures of +-- the term, avoiding capture by renaming βˆ€-binders. +substTypeVar + :: (Ord v, ABT.Var vt) + => vt + -> Type vt b + -> Term' vt v a + -> Term' vt v a +substTypeVar vt ty = go Set.empty where + go bound tm | Set.member vt bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where + fvs = ABT.freeVars ty + -- if the βˆ€ introduces a variable, v, which is free in `ty`, we pick a new + -- variable name for v which is unique, v', and rename v to v' in e. + uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let + v = ABT.variable body + v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v + t2 = ABT.bindInheritAnnotation body (Type.var() v2) + in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 + uncapture vs e t0 = let + t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a +renameTypeVar old new = go Set.empty where + go bound tm | Set.member old bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> let + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.rename old new (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- Converts free variables to bound variables using forall or introOuter. Example: +-- +-- foo : x -> x +-- foo a = +-- r : x +-- r = a +-- r +-- +-- This becomes: +-- +-- foo : βˆ€ x . x -> x +-- foo a = +-- r : outer x . x -- FYI, not valid syntax +-- r = a +-- r +-- +-- More specifically: in the expression `e : t`, unbound lowercase variables in `t` +-- are bound with foralls, and any βˆ€-quantified type variables are made bound in +-- `e` and its subexpressions. The result is a term with no lowercase free +-- variables in any of its type signatures, with outer references represented +-- with explicit `introOuter` binders. The resulting term may have uppercase +-- free variables that are still unbound. +generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a +generalizeTypeSignatures = go Set.empty where + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e (Type.generalizeLowercase bound -> t) -> let + bound' = case Type.unForalls t of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + in ann loc (go bound' e) (Type.freeVarsToOuters bound t) + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- nicer pattern syntax + +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst +pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) +pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) +pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) +pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) +pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) +pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) +pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) +pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) +pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) +pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) +pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) +pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) +pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) +pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) +pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) +pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) +pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) +pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) +pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) +pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) +pattern Apps' f args <- (unApps -> Just (f, args)) +-- begin pretty-printer helper patterns +pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) +pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) +pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) +pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +-- end pretty-printer helper patterns +pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) +pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) +pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) + +pattern Delay' body <- (unDelay -> Just body) +unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) +unDelay tm = case ABT.out tm of + ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) + | Set.notMember v (ABT.freeVars body) + -> Just body + _ -> Nothing + +pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) +pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) +pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) +pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) +pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) +pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) +pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) +pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) +pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) +pattern Lets' bs e <- (unLet -> Just (bs, e)) +pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) +pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) +pattern LetRec' subst <- (unLetRec -> Just (_, subst)) +pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) +pattern LetRecNamedAnnotatedTop' top ann bs e <- + (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) + +fresh :: Var v => Term0 v -> v -> v +fresh = ABT.fresh + +-- some smart constructors + +var :: a -> v -> Term2 vt at ap v a +var = ABT.annotatedVar + +var' :: Var v => Text -> Term0' vt v +var' = var() . Var.named + +ref :: Ord v => a -> Reference -> Term2 vt at ap v a +ref a r = ABT.tm' a (Ref r) + +pattern Referent' r <- (unReferent -> Just r) + +unReferent :: Term2 vt at ap v a -> Maybe Referent +unReferent (Ref' r) = Just $ Referent.Ref r +unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data +unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect +unReferent _ = Nothing + +refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Referent -> Term2 vt at ap v a +termLink a r = ABT.tm' a (TermLink r) + +typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a +typeLink a r = ABT.tm' a (TypeLink r) + +builtin :: Ord v => a -> Text -> Term2 vt at ap v a +builtin a n = ref a (Reference.Builtin n) + +float :: Ord v => a -> Double -> Term2 vt at ap v a +float a d = ABT.tm' a (Float d) + +boolean :: Ord v => a -> Bool -> Term2 vt at ap v a +boolean a b = ABT.tm' a (Boolean b) + +int :: Ord v => a -> Int64 -> Term2 vt at ap v a +int a d = ABT.tm' a (Int d) + +nat :: Ord v => a -> Word64 -> Term2 vt at ap v a +nat a d = ABT.tm' a (Nat d) + +text :: Ord v => a -> Text -> Term2 vt at ap v a +text a = ABT.tm' a . Text + +char :: Ord v => a -> Char -> Term2 vt at ap v a +char a = ABT.tm' a . Char + +watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a +watch a note e = + apps' (builtin a "Debug.watch") [text a (Text.pack note), e] + +watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a +watchMaybe Nothing e = e +watchMaybe (Just note) e = watch (ABT.annotation e) note e + +blank :: Ord v => a -> Term2 vt at ap v a +blank a = ABT.tm' a (Blank B.Blank) + +placeholder :: Ord v => a -> String -> Term2 vt a ap v a +placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) + +resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at +resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) + +constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +constructor a ref n = ABT.tm' a (Constructor ref n) + +request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +request a ref n = ABT.tm' a (Request ref n) + +-- todo: delete and rename app' to app +app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v +app_ f arg = ABT.tm (App f arg) + +app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +app a f arg = ABT.tm' a (App f arg) + +match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a +match a scrutinee branches = ABT.tm' a (Match scrutinee branches) + +handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +handle a h block = ABT.tm' a (Handle h block) + +and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +and a x y = ABT.tm' a (And x y) + +or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +or a x y = ABT.tm' a (Or x y) + +list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a +list a es = list' a (Sequence.fromList es) + +list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a +list' a es = ABT.tm' a (List es) + +apps + :: Ord v + => Term2 vt at ap v a + -> [(a, Term2 vt at ap v a)] + -> Term2 vt at ap v a +apps = foldl' (\f (a, t) -> app a f t) + +apps' + :: (Ord v, Semigroup a) + => Term2 vt at ap v a + -> [Term2 vt at ap v a] + -> Term2 vt at ap v a +apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) + +iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +iff a cond t f = ABT.tm' a (If cond t f) + +ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v +ann_ e t = ABT.tm (Ann e t) + +ann :: Ord v + => a + -> Term2 vt at ap v a + -> Type vt at + -> Term2 vt at ap v a +ann a e t = ABT.tm' a (Ann e t) + +-- arya: are we sure we want the two annotations to be the same? +lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a +lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) + +delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a +delay a body = + ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) + +lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam'' vs body = foldr (uncurry lam) body vs + +isLam :: Term2 vt at ap v a -> Bool +isLam t = arity t > 0 + +arity :: Term2 vt at ap v a -> Int +arity (LamNamed' _ body) = 1 + arity body +arity (Ann' e _) = arity e +arity _ = 0 + +unLetRecNamedAnnotated + :: Term' vt v a + -> Maybe + (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) +unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = + Just (isTop, ann, avs `zip` bs, e) +unLetRecNamedAnnotated _ = Nothing + +letRec' + :: (Ord v, Monoid a) + => Bool + -> [(v, Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec' isTop bindings body = + letRec isTop + (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) + [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] + body + +-- Prepend a binding to form a (bigger) let rec. Useful when +-- building up a block incrementally using a right fold. +-- +-- For example: +-- consLetRec (x = 42) "hi" +-- => +-- let rec x = 42 in "hi" +-- +-- consLetRec (x = 42) (let rec y = "hi" in (x,y)) +-- => +-- let rec x = 42; y = "hi" in (x,y) +consLetRec + :: Ord v + => Bool -- isTop parameter + -> a -- annotation for overall let rec + -> (a, v, Term' vt v a) -- the binding + -> Term' vt v a -- the body + -> Term' vt v a +consLetRec isTop a (ab, vb, b) body = case body of + LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body + _ -> letRec isTop a [((ab,vb),b)] body + +letRec + :: Ord v + => Bool + -> a + -> [((a, v), Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec _ _ [] e = e +letRec isTop a bindings e = ABT.cycle' + a + (foldr (uncurry ABT.abs' . fst) z bindings) + where z = ABT.tm' a (LetRec isTop (map snd bindings) e) + + +-- | Smart constructor for let rec blocks. Each binding in the block may +-- reference any other binding in the block in its body (including itself), +-- and the output expression may also reference any binding in the block. +letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v +letRec_ _ [] e = e +letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) + where + z = ABT.tm (LetRec isTop (map snd bindings) e) + +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. +-- todo: delete me +let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v +let1_ isTop bindings e = foldr f e bindings + where + f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) + +-- | annotations are applied to each nested Let expression +let1 + :: Ord v + => IsTop + -> [((a, v), Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1 isTop bindings e = foldr f e bindings + where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) + +let1' + :: (Semigroup a, Ord v) + => IsTop + -> [(v, Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1' isTop bindings e = foldr f e bindings + where + ann = ABT.annotation + f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) + where a = ann b <> ann body + +-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v +-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e + +unLet1 + :: Var v + => Term' vt v a + -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) +unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) +unLet1 _ = Nothing + +-- | Satisfies `unLet (let' bs e) == Just (bs, e)` +unLet + :: Term2 vt at ap v a + -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) +unLet t = fixup (go t) + where + go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of + (env, t) -> ((isTop, v, b) : env, t) + go t = ([], t) + fixup ([], _) = Nothing + fixup bst = Just bst + +-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` +unLetRecNamed + :: Term2 vt at ap v a + -> Maybe + ( IsTop + , [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) + | length vs == length bs = Just (isTop, zip vs bs, e) +unLetRecNamed _ = Nothing + +unLetRec + :: (Monad m, Var v) + => Term2 vt at ap v a + -> Maybe + ( IsTop + , (v -> m v) + -> m + ( [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) + ) +unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just + ( isTop + , \freshen -> do + vs <- sequence [ freshen v | (v, _) <- bs ] + let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) + pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) + ) +unLetRec _ = Nothing + +unApps + :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unApps t = unAppsPred (t, const True) + +-- Same as unApps but taking a predicate controlling whether we match on a given function argument. +unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) + where + go (App' i o) acc | pred o = go i (o:acc) + go _ [] = [] + go fn args = fn:args + +unBinaryApp :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a) +unBinaryApp t = case unApps t of + Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) + _ -> Nothing + +-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" +unBinaryApps + :: Term2 vt at ap v a + -> Maybe + ( [(Term2 vt at ap v a, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unBinaryApps t = unBinaryAppsPred (t, const True) + +-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. +unBinaryAppsPred :: (Term2 vt at ap v a + ,Term2 vt at ap v a -> Bool) + -> Maybe ([(Term2 vt at ap v a, + Term2 vt at ap v a)], + Term2 vt at ap v a) +unBinaryAppsPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + _ -> Nothing + +unLams' + :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLams' t = unLamsPred' (t, const True) + +-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a +-- lambda extraction. +unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLamsOpt' t = case unLams' t of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams', but stops at any variable named `()`, which indicates a +-- delay (`'`) annotation which we want to preserve. +unLamsUntilDelay' + :: Var v + => Term2 vt at ap v a + -> Maybe ([v], Term2 vt at ap v a) +unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams' but taking a predicate controlling whether we match on a given binary function. +unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> + Maybe ([v], Term2 vt at ap v a) +unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of + Nothing -> Just ([v], body) + Just (vs, body) -> Just (v:vs, body) +unLamsPred' _ = Nothing + +unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) +unReqOrCtor (Constructor' r cid) = Just (r, cid) +unReqOrCtor (Request' r cid) = Just (r, cid) +unReqOrCtor _ = Nothing + +-- Dependencies including referenced data and effect decls +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) + +termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +termDependencies = + Set.fromList + . mapMaybe + ( LD.fold + (\_typeRef -> Nothing) + ( Referent.fold + (\termRef -> Just termRef) + (\_typeConRef _i _ct -> Nothing) + ) + ) + . toList + . labeledDependencies + +-- gets types from annotations and constructors +typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +typeDependencies = + Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + +-- Gets the types to which this term contains references via patterns and +-- data constructors. +constructorDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +constructorDependencies = + Set.unions + . generalizedDependencies (const mempty) + (const mempty) + Set.singleton + (const . Set.singleton) + Set.singleton + (const . Set.singleton) + Set.singleton + +generalizedDependencies + :: (Ord v, Ord vt, Ord r) + => (Reference -> r) + -> (Reference -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Term2 vt at ap v a + -> Set r +generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . Writer.execWriter . ABT.visit' f where + f t@(Ref r) = Writer.tell [termRef r] $> t + f t@(TermLink r) = case r of + Referent.Ref r -> Writer.tell [termRef r] $> t + Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t + Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t + f t@(TypeLink r) = Writer.tell [typeRef r] $> t + f t@(Ann _ typ) = + Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t + f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t + f t@(Int _) = Writer.tell [literalType Type.intRef] $> t + f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t + f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t + f t@(Text _) = Writer.tell [literalType Type.textRef] $> t + f t@(List _) = Writer.tell [literalType Type.listRef] $> t + f t@(Constructor r cid) = + Writer.tell [dataType r, dataConstructor r cid] $> t + f t@(Request r cid) = + Writer.tell [effectType r, effectConstructor r cid] $> t + f t@(Match _ cases) = traverse_ goPat cases $> t + f t = pure t + goPat (MatchCase pat _ _) = + Writer.tell . toList $ Pattern.generalizedDependencies literalType + dataConstructor + dataType + effectConstructor + effectType + pat + +labeledDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.termRef + LD.typeRef + LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef + +updateDependencies + :: Ord v + => Map Reference Reference + -> Map Reference Reference + -> Term v a + -> Term v a +updateDependencies termUpdates typeUpdates = ABT.rebuildUp go + where + -- todo: this function might need tweaking if we ever allow type replacements + -- would need to look inside pattern matching and constructor calls + go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) + go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) + go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) + go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp + go f = f + +-- | If the outermost term is a function application, +-- perform substitution of the argument into the body +betaReduce :: Var v => Term0 v -> Term0 v +betaReduce (App' (Lam' f) arg) = ABT.bind f arg +betaReduce e = e + +betaNormalForm :: Var v => Term0 v -> Term0 v +betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) +betaNormalForm e = e + +-- x -> f x => f +etaNormalForm :: Ord v => Term0 v -> Term0 v +etaNormalForm tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + where + step (LamNamed' v (App' f (Var' v'))) | v == v' = f + step tm = tm + _ -> tm + +-- x -> f x => f as long as `x` is a variable of type `Var.Eta` +etaReduceEtaVars :: Var v => Term0 v -> Term0 v +etaReduceEtaVars tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + where + ok v v' = v == v' && Var.typeOf v == Var.Eta + step (LamNamed' v (App' f (Var' v'))) | ok v v' = f + step tm = tm + _ -> tm + +-- This converts `Reference`s it finds that are in the input `Map` +-- back to free variables +unhashComponent :: forall v a. Var v + => Map Reference (Term v a) + -> Map Reference (v, Term v a) +unhashComponent m = let + usedVars = foldMap (Set.fromList . ABT.allVars) m + m' :: Map Reference (v, Term v a) + m' = evalState (Map.traverseWithKey assignVar m) usedVars where + assignVar r t = (,t) <$> ABT.freshenS (refNamed r) + unhash1 = ABT.rebuildUp' go where + go e@(Ref' r) = case Map.lookup r m' of + Nothing -> e + Just (v, _) -> var (ABT.annotation e) v + go e = e + in second unhash1 <$> m' + where + -- Variable whose name is derived from the given reference. + refNamed :: Var v => Reference -> v + refNamed ref = Var.named ("ℍ" <> Reference.toText ref) + +hashComponents + :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +hashClosedTerm :: Var v => Term v a -> Reference.Id +hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 + +-- The hash for a constructor +hashConstructor' + :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +hashConstructor' f r cid = + let +-- this is a bit circuitous, but defining everything in terms of hashComponents +-- ensure the hashing is always done in the same way + m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) + in case toList m of + [(r, _)] -> Reference.DerivedId r + _ -> error "unpossible" + +hashConstructor :: Reference -> ConstructorId -> Reference +hashConstructor = hashConstructor' $ constructor () + +hashRequest :: Reference -> ConstructorId -> Reference +hashRequest = hashConstructor' $ request () + +fromReferent :: Ord v + => a + -> Referent + -> Term2 vt at ap v a +fromReferent a = \case + Referent.Ref r -> ref a r + Referent.Con r i ct -> case ct of + CT.Data -> constructor a r i + CT.Effect -> request a r i + +instance Var v => Hashable1 (F v a p) where + hash1 hashCycle hash e + = let (tag, hashed, varint) = + (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) + in + case e of + -- So long as `Reference.Derived` ctors are created using the same + -- hashing function as is used here, this case ensures that references + -- are 'transparent' wrt hash and hashing is unaffected by whether + -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash + -- the same. + Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) + Ref (Reference.Derived h i n) -> Hashable.accumulate + [ tag 1 + , hashed $ Hashable.fromBytes (Hash.toBytes h) + , Hashable.Nat i + , Hashable.Nat n + ] + -- Note: start each layer with leading `1` byte, to avoid collisions + -- with types, which start each layer with leading `0`. + -- See `Hashable1 Type.F` + _ -> + Hashable.accumulate + $ tag 1 + : case e of + Nat i -> [tag 64, accumulateToken i] + Int i -> [tag 65, accumulateToken i] + Float n -> [tag 66, Hashable.Double n] + Boolean b -> [tag 67, accumulateToken b] + Text t -> [tag 68, accumulateToken t] + Char c -> [tag 69, accumulateToken c] + Blank b -> tag 1 : case b of + B.Blank -> [tag 0] + B.Recorded (B.Placeholder _ s) -> + [tag 1, Hashable.Text (Text.pack s)] + B.Recorded (B.Resolve _ s) -> + [tag 2, Hashable.Text (Text.pack s)] + Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] + Ref Reference.Derived {} -> + error "handled above, but GHC can't figure this out" + App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] + Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] + List as -> tag 5 : varint (Sequence.length as) : map + (hashed . hash) + (toList as) + Lam a -> [tag 6, hashed (hash a)] + -- note: we use `hashCycle` to ensure result is independent of + -- let binding order + LetRec _ as a -> case hashCycle as of + (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs + -- here, order is significant, so don't use hashCycle + Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + If b t f -> + [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] + Request r n -> [tag 10, accumulateToken r, varint n] + Constructor r n -> [tag 12, accumulateToken r, varint n] + Match e branches -> + tag 13 : hashed (hash e) : concatMap h branches + where + h (MatchCase pat guard branch) = concat + [ [accumulateToken pat] + , toList (hashed . hash <$> guard) + , [hashed (hash branch)] + ] + Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] + And x y -> [tag 16, hashed $ hash x, hashed $ hash y] + Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] + TermLink r -> [tag 18, accumulateToken r] + TypeLink r -> [tag 19, accumulateToken r] + +-- mostly boring serialization code below ... + +instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec + +instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where + Int x == Int y = x == y + Nat x == Nat y = x == y + Float x == Float y = x == y + Boolean x == Boolean y = x == y + Text x == Text y = x == y + Char x == Char y = x == y + Blank b == Blank q = b == q + Ref x == Ref y = x == y + TermLink x == TermLink y = x == y + TypeLink x == TypeLink y = x == y + Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 + Request r cid == Request r2 cid2 = r == r2 && cid == cid2 + Handle h b == Handle h2 b2 = h == h2 && b == b2 + App f a == App f2 a2 = f == f2 && a == a2 + Ann e t == Ann e2 t2 = e == e2 && t == t2 + List v == List v2 = v == v2 + If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 + And a b == And a2 b2 = a == a2 && b == b2 + Or a b == Or a2 b2 = a == a2 && b == b2 + Lam a == Lam b = a == b + LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 + Let _ binding body == Let _ binding2 body2 = + binding == binding2 && body == body2 + Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 + _ == _ = False + + +instance (Show v, Show a) => Show (F v a0 p a) where + showsPrec = go + where + go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n + go _ (Nat n ) = shows n + go _ (Float n ) = shows n + go _ (Boolean True ) = s "true" + go _ (Boolean False) = s "false" + go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k + go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x + go _ (Lam body ) = showParen True (s "Ξ» " <> shows body) + go _ (List vs ) = showListWith shows (toList vs) + go _ (Blank b ) = case b of + B.Blank -> s "_" + B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) + B.Recorded (B.Resolve _ r) -> s r + go _ (Ref r) = s "Ref(" <> shows r <> s ")" + go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" + go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" + go _ (Let _ b body) = + showParen True (s "let " <> shows b <> s " in " <> shows body) + go _ (LetRec _ bs body) = showParen + True + (s "let rec" <> shows bs <> s " in " <> shows body) + go _ (Handle b body) = showParen + True + (s "handle " <> shows b <> s " in " <> shows body) + go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n + go _ (Match scrutinee cases) = showParen + True + (s "case " <> shows scrutinee <> s " of " <> shows cases) + go _ (Text s ) = shows s + go _ (Char c ) = shows c + go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n + go p (If c t f) = + showParen (p > 0) + $ s "if " + <> shows c + <> s " then " + <> shows t + <> s " else " + <> shows f + go p (And x y) = + showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y + go p (Or x y) = + showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y + (<>) = (.) + s = showString \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Type.hs b/parser-typechecker/src/Unison/Hashing/V2/Type.hs new file mode 100644 index 0000000000..cc2a6e0dc4 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Type.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Type where + +import Unison.Prelude + +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +-- | Base functor for types in the Unison language +data F a + = Ref Reference + | Arrow a a + | Ann a K.Kind + | App a a + | Effect a a + | Effects [a] + | Forall a + | IntroOuter a -- binder like βˆ€, used to introduce variables that are + -- bound by outer type signatures, to support scoped type + -- variables + deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) + +instance Eq1 F where (==#) = (==) +instance Ord1 F where compare1 = compare +instance Show1 F where showsPrec1 = showsPrec + +-- | Types are represented as ABTs over the base functor F, with variables in `v` +type Type v a = ABT.Term F v a + +wrapV :: Ord v => Type v a -> Type (ABT.V v) a +wrapV = ABT.vmap ABT.Bound + +freeVars :: Type v a -> Set v +freeVars = ABT.freeVars + +bindExternal + :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a +bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] + +bindReferences + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindReferences keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +bindNames + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq + +instance (Show v) => Show (Monotype v a) where + show = show . getPolytype + +-- Smart constructor which checks if a `Type` has no `Forall` quantifiers. +monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) +monotype t = Monotype <$> ABT.visit isMono t where + isMono (Forall' _) = Just Nothing + isMono _ = Nothing + +arity :: Type v a -> Int +arity (ForallNamed' _ body) = arity body +arity (Arrow' _ o) = 1 + arity o +arity (Ann' a _) = arity a +arity _ = 0 + +-- some smart patterns +pattern Ref' r <- ABT.Tm' (Ref r) +pattern Arrow' i o <- ABT.Tm' (Arrow i o) +pattern Arrow'' i es o <- Arrow' i (Effect'' es o) +pattern Arrows' spine <- (unArrows -> Just spine) +pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) +pattern Ann' t k <- ABT.Tm' (Ann t k) +pattern App' f x <- ABT.Tm' (App f x) +pattern Apps' f args <- (unApps -> Just (f, args)) +pattern Pure' t <- (unPure -> Just t) +pattern Effects' es <- ABT.Tm' (Effects es) +-- Effect1' must match at least one effect +pattern Effect1' e t <- ABT.Tm' (Effect e t) +pattern Effect' es t <- (unEffects1 -> Just (es, t)) +pattern Effect'' es t <- (unEffect0 -> (es, t)) +-- Effect0' may match zero effects +pattern Effect0' es t <- (unEffect0 -> (es, t)) +pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) +pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) +pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) +pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) +pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst + +unPure :: Ord v => Type v a -> Maybe (Type v a) +unPure (Effect'' [] t) = Just t +unPure (Effect'' _ _) = Nothing +unPure t = Just t + +unArrows :: Type v a -> Maybe [Type v a] +unArrows t = + case go t of [_] -> Nothing; l -> Just l + where go (Arrow' i o) = i : go o + go o = [o] + +unEffectfulArrows + :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) +unEffectfulArrows t = case t of + Arrow' i o -> Just (i, go o) + _ -> Nothing + where + go (Effect1' (Effects' es) (Arrow' i o)) = + (Just $ es >>= flattenEffects, i) : go o + go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] + go (Arrow' i o) = (Nothing, i) : go o + go t = [(Nothing, t)] + +unApps :: Type v a -> Maybe (Type v a, [Type v a]) +unApps t = case go t [] of + [] -> Nothing + [ _ ] -> Nothing + f : args -> Just (f, args) + where + go (App' i o) acc = go i (o : acc) + go fn args = fn : args + +unIntroOuters :: Type v a -> Maybe ([v], Type v a) +unIntroOuters t = go t [] + where go (IntroOuterNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just (reverse vs, body) + +-- Most code doesn't care about `introOuter` binders and is fine dealing with the +-- these outer variable references as free variables. This function strips out +-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. +stripIntroOuters :: Type v a -> Type v a +stripIntroOuters t = case unIntroOuters t of + Just (_, t) -> t + Nothing -> t + +unForalls :: Type v a -> Maybe ([v], Type v a) +unForalls t = go t [] + where go (ForallNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just(reverse vs, body) + +unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) +unEffect0 (Effect1' e a) = (flattenEffects e, a) +unEffect0 t = ([], t) + +unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) +unEffects1 (Effect1' (Effects' es) a) = Just (es, a) +unEffects1 _ = Nothing + +-- | True if the given type is a function, possibly quantified +isArrow :: ABT.Var v => Type v a -> Bool +isArrow (ForallNamed' _ t) = isArrow t +isArrow (Arrow' _ _) = True +isArrow _ = False + +-- some smart constructors + +ref :: Ord v => a -> Reference -> Type v a +ref a = ABT.tm' a . Ref + +refId :: Ord v => a -> Reference.Id -> Type v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Type v a +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 r a = ref a r + +intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference +intRef = Reference.Builtin "Int" +natRef = Reference.Builtin "Nat" +floatRef = Reference.Builtin "Float" +booleanRef = Reference.Builtin "Boolean" +textRef = Reference.Builtin "Text" +charRef = Reference.Builtin "Char" +listRef = Reference.Builtin "Sequence" +bytesRef = Reference.Builtin "Bytes" +effectRef = Reference.Builtin "Effect" +termLinkRef = Reference.Builtin "Link.Term" +typeLinkRef = Reference.Builtin "Link.Type" + +builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference +builtinIORef = Reference.Builtin "IO" +fileHandleRef = Reference.Builtin "Handle" +filePathRef = Reference.Builtin "FilePath" +threadIdRef = Reference.Builtin "ThreadId" +socketRef = Reference.Builtin "Socket" + +mvarRef, tvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +tvarRef = Reference.Builtin "TVar" + +tlsRef :: Reference +tlsRef = Reference.Builtin "Tls" + +stmRef :: Reference +stmRef = Reference.Builtin "STM" + +tlsClientConfigRef :: Reference +tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" + +tlsServerConfigRef :: Reference +tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" + +tlsSignedCertRef :: Reference +tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" + +tlsPrivateKeyRef :: Reference +tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" + +tlsCipherRef :: Reference +tlsCipherRef = Reference.Builtin "Tls.Cipher" + +tlsVersionRef :: Reference +tlsVersionRef = Reference.Builtin "Tls.Version" + +hashAlgorithmRef :: Reference +hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" + +codeRef, valueRef :: Reference +codeRef = Reference.Builtin "Code" +valueRef = Reference.Builtin "Value" + +anyRef :: Reference +anyRef = Reference.Builtin "Any" + +any :: Ord v => a -> Type v a +any a = ref a anyRef + +builtin :: Ord v => a -> Text -> Type v a +builtin a = ref a . Reference.Builtin + +int :: Ord v => a -> Type v a +int a = ref a intRef + +nat :: Ord v => a -> Type v a +nat a = ref a natRef + +float :: Ord v => a -> Type v a +float a = ref a floatRef + +boolean :: Ord v => a -> Type v a +boolean a = ref a booleanRef + +text :: Ord v => a -> Type v a +text a = ref a textRef + +char :: Ord v => a -> Type v a +char a = ref a charRef + +fileHandle :: Ord v => a -> Type v a +fileHandle a = ref a fileHandleRef + +threadId :: Ord v => a -> Type v a +threadId a = ref a threadIdRef + +builtinIO :: Ord v => a -> Type v a +builtinIO a = ref a builtinIORef + +socket :: Ord v => a -> Type v a +socket a = ref a socketRef + +list :: Ord v => a -> Type v a +list a = ref a listRef + +bytes :: Ord v => a -> Type v a +bytes a = ref a bytesRef + +effectType :: Ord v => a -> Type v a +effectType a = ref a $ effectRef + +code, value :: Ord v => a -> Type v a +code a = ref a codeRef +value a = ref a valueRef + +app :: Ord v => a -> Type v a -> Type v a -> Type v a +app a f arg = ABT.tm' a (App f arg) + +-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one +-- meant for `app (f x) y` +apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a +apps = foldl' go where go f (a, t) = app a f t + +app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a +app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg + +apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a +apps' = foldl app' + +arrow :: Ord v => a -> Type v a -> Type v a -> Type v a +arrow a i o = ABT.tm' a (Arrow i o) + +arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a +arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o + +ann :: Ord v => a -> Type v a -> K.Kind -> Type v a +ann a e t = ABT.tm' a (Ann e t) + +forall :: Ord v => a -> v -> Type v a -> Type v a +forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) + +introOuter :: Ord v => a -> v -> Type v a -> Type v a +introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) + +iff :: Var v => Type v () +iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a + where aa = Var.named "a" + a = var () aa + f x = ((), x) + +iff' :: Var v => a -> Type v a +iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +iff2 :: Var v => a -> Type v a +iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +andor :: Ord v => Type v () +andor = arrows (f <$> [boolean(), boolean()]) $ boolean() + where f x = ((), x) + +andor' :: Ord v => a -> Type v a +andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a + where f x = (a, x) + +var :: Ord v => a -> v -> Type v a +var = ABT.annotatedVar + +v' :: Var v => Text -> Type v () +v' s = ABT.var (Var.named s) + +-- Like `v'`, but creates an annotated variable given an annotation +av' :: Var v => a -> Text -> Type v a +av' a s = ABT.annotatedVar a (Var.named s) + +forall' :: Var v => a -> [Text] -> Type v a -> Type v a +forall' a vs body = foldr (forall a) body (Var.named <$> vs) + +foralls :: Ord v => a -> [v] -> Type v a -> Type v a +foralls a vs body = foldr (forall a) body vs + +-- Note: `a -> b -> c` parses as `a -> (b -> c)` +-- the annotation associated with `b` will be the annotation for the `b -> c` +-- node +arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a +arrows ts result = foldr go result ts where + go = uncurry arrow + +-- The types of effectful computations +effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a +effect a es (Effect1' fs t) = + let es' = (es >>= flattenEffects) ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) + +effects :: Ord v => a -> [Type v a] -> Type v a +effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) + +effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a +effect1 a es (Effect1' fs t) = + let es' = flattenEffects es ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect1 a es t = ABT.tm' a (Effect es t) + +flattenEffects :: Type v a -> [Type v a] +flattenEffects (Effects' es) = es >>= flattenEffects +flattenEffects es = [es] + +-- The types of first-class effect values +-- which get deconstructed in effect handlers. +effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a +effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] + +-- Strips effects from a type. E.g. `{e} a` becomes `a`. +stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) +stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) +stripEffect t = ([], t) + +-- The type of the flipped function application operator: +-- `(a -> (a -> b) -> b)` +flipApply :: Var v => Type v () -> Type v () +flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) + where b = ABT.fresh t (Var.named "b") + +generalize' :: Var v => Var.Type -> Type v a -> Type v a +generalize' k t = generalize vsk t where + vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] + +-- | Bind the given variables with an outer `forall`, if they are used in `t`. +generalize :: Ord v => [v] -> Type v a -> Type v a +generalize vs t = foldr f t vs + where + f v t = + if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + +unforall :: Type v a -> Type v a +unforall (ForallsNamed' _ t) = t +unforall t = t + +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 t = Set.fromList . Writer.execWriter $ ABT.visit' f t + where f t@(Ref r) = Writer.tell [r] $> t + f t = pure t + +updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a +updateDependencies typeUpdates = ABT.rebuildUp go + where + go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) + go f = f + +usesEffects :: Ord v => Type v a -> Bool +usesEffects t = getAny . getConst $ ABT.visit go t where + go (Effect1' _ _) = Just (Const (Any True)) + go _ = Nothing + +-- Returns free effect variables in the given type, for instance, in: +-- +-- βˆ€ e3 . a ->{e,e2} b ->{e3} c +-- +-- This function would return the set {e, e2}, but not `e3` since `e3` +-- is bound by the enclosing forall. +freeEffectVars :: Ord v => Type v a -> Set v +freeEffectVars t = + Set.fromList . join . runIdentity $ + ABT.foreachSubterm go (snd <$> ABT.annotateBound t) + where + go t@(Effects' es) = + let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go t@(Effect1' e _) = + let frees = Set.fromList [ v | Var' v <- flattenEffects e ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go _ = pure [] + +-- Converts all unadorned arrows in a type to have fresh +-- existential ability requirements. For example: +-- +-- (a -> b) -> [a] -> [b] +-- +-- Becomes +-- +-- (a ->{e1} b) ->{e2} [a] ->{e3} [b] +existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) +existentializeArrows newVar t = ABT.visit go t + where + go t@(Arrow' a b) = case b of + -- If an arrow already has attached abilities, + -- leave it alone. Ex: `a ->{e} b` is kept as is. + Effect1' _ _ -> Just $ do + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + pure $ arrow (ABT.annotation t) a b + -- For unadorned arrows, make up a fresh variable. + -- So `a -> b` becomes `a ->{e} b`, using the + -- `newVar` variable generator. + _ -> Just $ do + e <- newVar + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + let ann = ABT.annotation t + pure $ arrow ann a (effect ann [var ann e] b) + go _ = Nothing + +purifyArrows :: (Ord v) => Type v a -> Type v a +purifyArrows = ABT.visitPure go + where + go t@(Arrow' a b) = case b of + Effect1' _ _ -> Nothing + _ -> Just $ arrow ann a (effect ann [] b) + where ann = ABT.annotation t + go _ = Nothing + +-- Remove free effect variables from the type that are in the set +removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a +removeEffectVars removals t = + let z = effects () [] + t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t + -- leave explicitly empty `{}` alone + removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) + removeEmpty t@(Effect1' e v) = + case flattenEffects e of + [] -> Just (ABT.visitPure removeEmpty v) + es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) + removeEmpty t@(Effects' es) = + Just $ effects (ABT.annotation t) (es >>= flattenEffects) + removeEmpty _ = Nothing + in ABT.visitPure removeEmpty t' + +-- Remove all effect variables from the type. +-- Used for type-based search, we apply this transformation to both the +-- indexed type and the query type, so the user can supply `a -> b` that will +-- match `a ->{e} b` (but not `a ->{IO} b`). +removeAllEffectVars :: ABT.Var v => Type v a -> Type v a +removeAllEffectVars t = let + allEffectVars = foldMap go (ABT.subterms t) + go (Effects' vs) = Set.fromList [ v | Var' v <- vs] + go (Effect1' (Var' v) _) = Set.singleton v + go _ = mempty + (vs, tu) = unforall' t + in generalize vs (removeEffectVars allEffectVars tu) + +removePureEffects :: ABT.Var v => Type v a -> Type v a +removePureEffects t | not Settings.removePureEffects = t + | otherwise = + generalize vs $ removeEffectVars (Set.filter isPure fvs) tu + where + (vs, tu) = unforall' t + fvs = freeEffectVars tu `Set.difference` ABT.freeVars t + -- If an effect variable is mentioned only once, it is on + -- an arrow `a ->{e} b`. Generalizing this to + -- `βˆ€ e . a ->{e} b` gives us the pure arrow `a -> b`. + isPure v = ABT.occurrences v tu <= 1 + +editFunctionResult + :: forall v a + . Ord v + => (Type v a -> Type v a) + -> Type v a + -> Type v a +editFunctionResult f = go + where + go :: Type v a -> Type v a + go (ABT.Term s a t) = case t of + ABT.Tm (Forall t) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t + ABT.Tm (Arrow i o) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o + ABT.Abs v r -> + (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r + _ -> f (ABT.Term s a t) + +functionResult :: Type v a -> Maybe (Type v a) +functionResult = go False + where + go inArr (ForallNamed' _ body) = go inArr body + go _inArr (Arrow' _i o ) = go True o + go inArr t = if inArr then Just t else Nothing + + +-- | Bind all free variables (not in `except`) that start with a lowercase +-- letter and are unqualified with an outer `forall`. +-- `a -> a` becomes `βˆ€ a . a -> a` +-- `B -> B` becomes `B -> B` (not changed) +-- `.foo -> .foo` becomes `.foo -> .foo` (not changed) +-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) +generalizeLowercase :: Var v => Set v -> Type v a -> Type v a +generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars + where + vars = + [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] + +-- Convert all free variables in `allowed` to variables bound by an `introOuter`. +freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a +freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars + where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed + +-- | This function removes all variable shadowing from the types and reduces +-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing +-- two different types. +cleanupVars :: Var v => [Type v a] -> [Type v a] +cleanupVars ts | not Settings.cleanupTypes = ts +cleanupVars ts = let + changedVars = cleanupVarsMap ts + in cleanupVars1' changedVars <$> ts + +-- Compute a variable replacement map from a collection of types, which +-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids +-- for multiple related types, like when reporting a type error. +cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v +cleanupVarsMap ts = let + varsByName = foldl' step Map.empty (ts >>= ABT.allVars) + step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m + changedVars = Map.fromList [ (v, Var.freshenId i v) + | (_, vs) <- Map.toList varsByName + , (v,i) <- nubOrd vs `zip` [0..]] + in changedVars + +cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a +cleanupVars1' = ABT.changeVars + +-- | This function removes all variable shadowing from the type and reduces +-- fresh ids to the minimum possible to avoid ambiguity. +cleanupVars1 :: Var v => Type v a -> Type v a +cleanupVars1 t | not Settings.cleanupTypes = t +cleanupVars1 t = let [t'] = cleanupVars [t] in t' + +-- This removes duplicates and normalizes the order of ability lists +cleanupAbilityLists :: Var v => Type v a -> Type v a +cleanupAbilityLists = ABT.visitPure go + where + -- leave explicitly empty `{}` alone + go (Effect1' (Effects' []) _v) = Nothing + go t@(Effect1' e v) = + let es = Set.toList . Set.fromList $ flattenEffects e + in case es of + [] -> Just (ABT.visitPure go v) + _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) + go _ = Nothing + +cleanups :: Var v => [Type v a] -> [Type v a] +cleanups ts = cleanupVars $ map cleanupAbilityLists ts + +cleanup :: Var v => Type v a -> Type v a +cleanup t | not Settings.cleanupTypes = t +cleanup t = cleanupVars1 . cleanupAbilityLists $ t + +toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference (Ref' r) = r +-- a bit of normalization - any unused type parameters aren't part of the hash +toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +toReference t = Reference.Derived (ABT.hash t) 0 1 + +toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions ty = + let (vs, _) = unforall' ty + gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty + in Set.fromList $ toReference . gen <$> ABT.subterms ty + +hashComponents + :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +instance Hashable1 F where + hash1 hashCycle hash e = + let + (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `0` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 0 : case e of + Ref r -> [tag 0, Hashable.accumulateToken r] + Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] + App a b -> [tag 2, hashed (hash a), hashed (hash b) ] + Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] + -- Example: + -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as + -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from + -- c) {Remote, Abort} (() -> {Abort} ()) + Effects es -> let + (hs, _) = hashCycle es + in tag 4 : map hashed hs + Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] + Forall a -> [tag 6, hashed (hash a)] + IntroOuter a -> [tag 7, hashed (hash a)] + +instance Show a => Show (F a) where + showsPrec = go where + go _ (Ref r) = shows r + go p (Arrow i o) = + showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o + go p (Ann t k) = + showParen (p > 1) $ shows t <> s":" <> shows k + go p (App f x) = + showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x + go p (Effects es) = showParen (p > 0) $ + s"{" <> shows es <> s"}" + go p (Effect e t) = showParen (p > 0) $ + showParen True $ shows e <> s" " <> showsPrec p t + go p (Forall body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"βˆ€ " <> shows body + go p (IntroOuter body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"outer " <> shows body + (<>) = (.) + s = showString diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 12c2fde690..38fb22de19 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -11,6 +11,9 @@ module Unison.Lexer ( escapeChars, debugFileLex, debugLex', debugLex'', debugLex''', showEscapeChar, touches, + typeModifiers, + typeOrAbilityAlt, + typeModifiersAlt, -- todo: these probably don't belong here wordyIdChar, wordyIdStartChar, wordyId, symbolyId, wordyId0, symbolyId0) @@ -36,14 +39,9 @@ import qualified Text.Megaparsec.Error as EP import qualified Text.Megaparsec.Char as CP import Text.Megaparsec.Char (char) import qualified Text.Megaparsec.Char.Lexer as LP +import Unison.Lexer.Pos (Pos (Pos), Column, Line, column, line) import qualified Unison.Util.Bytes as Bytes -type Line = Int -type Column = Int - -data Pos = Pos {-# Unpack #-} !Line {-# Unpack #-} !Column deriving (Eq,Ord) -instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col - type BlockName = String type Layout = [(BlockName,Column)] @@ -92,6 +90,7 @@ data Err | InvalidEscapeCharacter Char | LayoutError | CloseWithoutMatchingOpen String String -- open, close + | UnexpectedDelimiter String | Opaque String -- Catch-all failure type, generally these will be -- automatically generated errors coming from megaparsec -- Try to avoid this for common errors a user is likely to see. @@ -216,7 +215,8 @@ token'' tok p = do topHasClosePair :: Layout -> Bool topHasClosePair [] = False - topHasClosePair ((name,_):_) = name `elem` ["{", "(", "handle", "match", "if", "then"] + topHasClosePair ((name,_):_) = + name `elem` ["{", "(", "[", "handle", "match", "if", "then"] lexer0' :: String -> String -> [Token Lexeme] lexer0' scope rem = @@ -330,7 +330,9 @@ lexemes' eof = P.optional space >> do wordyKw kw = separated wordySep (lit kw) subsequentTypeName = P.lookAhead . P.optional $ do let lit' s = lit s <* sp - _ <- P.optional (lit' "unique") *> (wordyKw "type" <|> wordyKw "ability") <* sp + let modifier = typeModifiersAlt lit' + let typeOrAbility' = typeOrAbilityAlt wordyKw + _ <- modifier <* typeOrAbility' *> sp wordyId ignore _ _ _ = [] body = join <$> P.many (sectionElem <* CP.space) @@ -340,22 +342,24 @@ lexemes' eof = P.optional space >> do isPrefixOf "}}" word || all (== '#') word - wordy ok = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do - let end = P.lookAhead $ void docClose - <|> void docOpen - <|> void (CP.satisfy isSpace) - <|> void (CP.satisfy (not . ok)) - word <- P.someTill (CP.satisfy (\ch -> not (isSpace ch) && ok ch)) end - guard (not $ reserved word) + wordy closing = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do + let end = + P.lookAhead + $ void docClose + <|> void docOpen + <|> void (CP.satisfy isSpace) + <|> void closing + word <- P.manyTill (CP.satisfy (\ch -> not (isSpace ch))) end + guard (not $ reserved word || null word) pure word - leafy ok = groupy ok gs - where - gs = link <|> externalLink <|> exampleInline <|> expr - <|> boldOrItalicOrStrikethrough ok <|> verbatim - <|> atDoc <|> wordy ok + leafy closing = groupy closing gs + where + gs = link <|> externalLink <|> exampleInline <|> expr + <|> boldOrItalicOrStrikethrough closing <|> verbatim + <|> atDoc <|> wordy closing - leaf = leafy (const True) + leaf = leafy mzero atDoc = src <|> evalInline <|> signature <|> signatureInline where @@ -392,7 +396,7 @@ lexemes' eof = P.optional space >> do pure s typeLink = wrap "syntax.docEmbedTypeLink" $ do - _ <- (lit "type" <|> lit "ability") <* CP.space + _ <- typeOrAbilityAlt lit <* CP.space tok (symbolyId <|> wordyId) <* CP.space termLink = wrap "syntax.docEmbedTermLink" $ @@ -401,9 +405,9 @@ lexemes' eof = P.optional space >> do signatureLink = wrap "syntax.docEmbedSignatureLink" $ tok (symbolyId <|> wordyId) <* CP.space - groupy ok p = do + groupy closing p = do (start,p,stop) <- positioned p - after <- P.optional . P.try $ leafy ok + after <- P.optional . P.try $ leafy closing pure $ case after of Nothing -> p Just after -> @@ -484,28 +488,30 @@ lexemes' eof = P.optional space >> do verbatim <- tok $ Textual . trim <$> P.someTill CP.anyChar ([] <$ lit fence) pure (name <> verbatim) - boldOrItalicOrStrikethrough ok = do - let start = some (CP.satisfy (== '*')) <|> some (CP.satisfy (== '_')) <|> some (CP.satisfy (== '~')) - name s = if take 1 s == "~" then "syntax.docStrikethrough" - else if length s > 1 then "syntax.docBold" - else "syntax.docItalic" - (end,ch) <- P.try $ do - end@(ch:_) <- start + boldOrItalicOrStrikethrough closing = do + let start = + some (CP.satisfy (== '*')) <|> some (CP.satisfy (== '_')) <|> some + (CP.satisfy (== '~')) + name s = if take 1 s == "~" + then "syntax.docStrikethrough" + else if take 1 s == "*" then "syntax.docBold" else "syntax.docItalic" + end <- P.try $ do + end <- start P.lookAhead (CP.satisfy (not . isSpace)) - pure (end,ch) - wrap (name end) . wrap "syntax.docParagraph" $ - join <$> P.someTill (leafy (\c -> ok c && c /= ch) <* nonNewlineSpaces) - (lit end) + pure end + wrap (name end) . wrap "syntax.docParagraph" $ join <$> P.someTill + (leafy (closing <|> (void $ lit end)) <* nonNewlineSpaces) + (lit end) externalLink = P.label "hyperlink (example: [link name](https://destination.com))" $ wrap "syntax.docNamedLink" $ do _ <- lit "[" - p <- leafies (/= ']') + p <- leafies (void $ char ']') _ <- lit "]" _ <- lit "(" target <- wrap "syntax.docGroup" . wrap "syntax.docJoin" $ - link <|> fmap join (P.some (expr <|> wordy (/= ')'))) + link <|> fmap join (P.some (expr <|> wordy (char ')'))) _ <- lit ")" pure (p <> target) @@ -771,13 +777,29 @@ lexemes' eof = P.optional space >> do reserved :: P [Token Lexeme] reserved = - token' (\ts _ _ -> ts) $ - braces <|> parens <|> delim <|> delayOrForce <|> keywords <|> layoutKeywords - where - keywords = symbolyKw ":" <|> symbolyKw "@" <|> symbolyKw "||" <|> symbolyKw "|" <|> symbolyKw "&&" - <|> wordyKw "true" <|> wordyKw "false" - <|> wordyKw "use" <|> wordyKw "forall" <|> wordyKw "βˆ€" - <|> wordyKw "termLink" <|> wordyKw "typeLink" + token' (\ts _ _ -> ts) + $ braces + <|> parens + <|> brackets + <|> commaSeparator + <|> delim + <|> delayOrForce + <|> keywords + <|> layoutKeywords + where + keywords = + symbolyKw ":" + <|> symbolyKw "@" + <|> symbolyKw "||" + <|> symbolyKw "|" + <|> symbolyKw "&&" + <|> wordyKw "true" + <|> wordyKw "false" + <|> wordyKw "use" + <|> wordyKw "forall" + <|> wordyKw "βˆ€" + <|> wordyKw "termLink" + <|> wordyKw "typeLink" wordyKw s = separated wordySep (kw s) symbolyKw s = separated (not . symbolyIdChar) (kw s) @@ -792,7 +814,9 @@ lexemes' eof = P.optional space >> do where ifElse = openKw "if" <|> close' (Just "then") ["if"] (lit "then") <|> close' (Just "else") ["then"] (lit "else") - typ = openKw1 wordySep "unique" <|> openTypeKw1 "type" <|> openTypeKw1 "ability" + modKw = typeModifiersAlt (openKw1 wordySep) + typeOrAbilityKw = typeOrAbilityAlt openTypeKw1 + typ = modKw <|> typeOrAbilityKw withKw = do [Token _ pos1 pos2] <- wordyKw "with" @@ -807,12 +831,14 @@ lexemes' eof = P.optional space >> do let opens = [Token (Open "with") pos1 pos2] pure $ replicate n (Token Close pos1 pos2) ++ opens - -- In `unique type` and `unique ability`, only the `unique` opens a layout block, + -- In `structural/unique type` and `structural/unique ability`, + -- only the `structural` or `unique` opens a layout block, -- and `ability` and `type` are just keywords. openTypeKw1 t = do b <- S.gets (topBlockName . layout) - case b of Just "unique" -> wordyKw t - _ -> openKw1 wordySep t + case b of + Just mod | Set.member mod typeModifiers -> wordyKw t + _ -> openKw1 wordySep t -- layout keyword which bumps the layout column by 1, rather than looking ahead -- to the next token to determine the layout column @@ -827,7 +853,7 @@ lexemes' eof = P.optional space >> do env <- S.get case topBlockName (layout env) of -- '=' does not open a layout block if within a type declaration - Just t | t == "type" || t == "unique" -> pure [Token (Reserved "=") start end] + Just t | t == "type" || Set.member t typeModifiers -> pure [Token (Reserved "=") start end] Just _ -> S.put (env { opening = Just "=" }) >> pure [Token (Open "=") start end] _ -> err start LayoutError @@ -836,7 +862,7 @@ lexemes' eof = P.optional space >> do env <- S.get -- -> introduces a layout block if we're inside a `match with` or `cases` case topBlockName (layout env) of - Just match | match == "match-with" || match == "cases" -> do + Just match | match `elem` matchWithBlocks -> do S.put (env { opening = Just "->" }) pure [Token (Open "->") start end] _ -> pure [Token (Reserved "->") start end] @@ -850,7 +876,20 @@ lexemes' eof = P.optional space >> do inLayout <- S.gets inLayout when (not inLayout) $ void $ P.lookAhead (CP.satisfy (/= '}')) pure l + matchWithBlocks = ["match-with", "cases"] parens = open "(" <|> close ["("] (lit ")") + brackets = open "[" <|> close ["["] (lit "]") + -- `allowCommaToClose` determines if a comma should close inner blocks. + -- Currently there is a set of blocks where `,` is not treated specially + -- and it just emits a Reserved ",". There are currently only three: + -- `cases`, `match-with`, and `{` + allowCommaToClose match = not $ match `elem` ("{" : matchWithBlocks) + commaSeparator = do + env <- S.get + case topBlockName (layout env) of + Just match | allowCommaToClose match -> + blockDelimiter ["[", "("] (lit ",") + _ -> fail "this comma is a pattern separator" delim = P.try $ do ch <- CP.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) @@ -878,6 +917,18 @@ lexemes' eof = P.optional space >> do close = close' Nothing + blockDelimiter :: [String] -> P String -> P [Token Lexeme] + blockDelimiter open closeP = do + (pos1, close, pos2) <- positioned $ closeP + env <- S.get + case findClose open (layout env) of + Nothing -> err pos1 (UnexpectedDelimiter (quote close)) + where quote s = "'" <> s <> "'" + Just (_, n) -> do + S.put (env { layout = drop (n-1) (layout env) }) + let delims = [Token (Reserved close) pos1 pos2] + pure $ replicate (n-1) (Token Close pos1 pos2) ++ delims + close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] close' reopenBlockname open closeP = do (pos1, close, pos2) <- positioned $ closeP @@ -908,12 +959,6 @@ notLayout t = case payload t of Open _ -> False _ -> True -line :: Pos -> Line -line (Pos line _) = line - -column :: Pos -> Column -column (Pos _ column) = column - -- `True` if the tokens are adjacent, with no space separating the two touches :: Token a -> Token b -> Bool touches (end -> t) (start -> t2) = @@ -981,9 +1026,8 @@ reorder :: [T (Token Lexeme)] -> [T (Token Lexeme)] reorder = join . sortWith f . stanzas where f [] = 3 :: Int f (t0 : _) = case payload $ headToken t0 of - Open "type" -> 1 - Open "unique" -> 1 - Open "ability" -> 1 + Open mod | Set.member mod typeModifiers -> 1 + Open typOrA | Set.member typOrA typeOrAbility -> 1 Reserved "use" -> 0 _ -> 3 :: Int @@ -1089,11 +1133,25 @@ symbolyIdChars = Set.fromList "!$%^&*-=+<>.~\\/|:" keywords :: Set String keywords = Set.fromList [ "if", "then", "else", "forall", "βˆ€", - "handle", "with", "unique", + "handle", "with", "where", "use", "true", "false", - "type", "ability", "alias", "typeLink", "termLink", - "let", "namespace", "match", "cases"] + "alias", "typeLink", "termLink", + "let", "namespace", "match", "cases"] <> typeModifiers <> typeOrAbility + +typeOrAbility :: Set String +typeOrAbility = Set.fromList ["type", "ability"] + +typeOrAbilityAlt :: Alternative f => (String -> f a) -> f a +typeOrAbilityAlt f = + asum $ map f (toList typeOrAbility) + +typeModifiers :: Set String +typeModifiers = Set.fromList ["structural", "unique"] + +typeModifiersAlt :: Alternative f => (String -> f a) -> f a +typeModifiersAlt f = + asum $ map f (toList typeModifiers) delimiters :: Set Char delimiters = Set.fromList "()[]{},?;" @@ -1178,12 +1236,3 @@ instance ShowToken (Token Lexeme) where instance Applicative Token where pure a = Token a (Pos 0 0) (Pos 0 0) Token f start _ <*> Token a _ end = Token (f a) start end - -instance Semigroup Pos where (<>) = mappend - -instance Monoid Pos where - mempty = Pos 0 0 - Pos line col `mappend` Pos line2 col2 = - if line2 == 0 then Pos line (col + col2) - else Pos (line + line2) col2 - diff --git a/parser-typechecker/src/Unison/Lexer/Pos.hs b/parser-typechecker/src/Unison/Lexer/Pos.hs new file mode 100644 index 0000000000..6e529d1d17 --- /dev/null +++ b/parser-typechecker/src/Unison/Lexer/Pos.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Lexer.Pos (Pos (..), Line, Column, line, column) where + +type Line = Int +type Column = Int + +data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column deriving (Eq, Ord) + +line :: Pos -> Line +line (Pos line _) = line + +column :: Pos -> Column +column (Pos _ column) = column + +instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col + +instance Semigroup Pos where (<>) = mappend + +instance Monoid Pos where + mempty = Pos 0 0 + Pos line col `mappend` Pos line2 col2 = + if line2 == 0 + then Pos line (col + col2) + else Pos (line + line2) col2 diff --git a/parser-typechecker/src/Unison/NamePrinter.hs b/parser-typechecker/src/Unison/NamePrinter.hs index 3d90878c8b..e14c41d3c5 100644 --- a/parser-typechecker/src/Unison/NamePrinter.hs +++ b/parser-typechecker/src/Unison/NamePrinter.hs @@ -12,11 +12,12 @@ import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH -import Unison.Util.SyntaxText (SyntaxText) import qualified Unison.Util.SyntaxText as S import Unison.Util.Pretty (Pretty) import qualified Unison.Util.Pretty as PP +type SyntaxText = S.SyntaxText' Reference + prettyName :: IsString s => Name -> Pretty s prettyName = PP.text . Name.toText diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 586ba25ccf..0d57784a08 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -1,10 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} module Unison.Parser where import Unison.Prelude + ( trace, + join, + foldl', + Text, + optional, + Alternative((<|>), many), + Set, + void, + when, + fromMaybe, + isJust, + listToMaybe, + encodeUtf8, + lastMay ) import qualified Crypto.Random as Random import Data.Bytes.Put (runPutS) @@ -29,15 +44,17 @@ import qualified Unison.Pattern as Pattern import Unison.Term (MatchCase (..)) import Unison.Var (Var) import qualified Unison.Var as Var -import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Error as UF import Unison.Util.Bytes (Bytes) import Unison.Name as Name import Unison.Names3 (Names) -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import Control.Monad.Reader.Class (asks) import qualified Unison.Hashable as Hashable import Unison.Referent (Referent) import Unison.Reference (Reference) +import Unison.Parser.Ann (Ann(..)) +import Text.Megaparsec.Error (ShowErrorComponent) debug :: Bool debug = False @@ -101,6 +118,8 @@ data Error v | UseEmpty (L.Token String) -- an empty `use` statement | DidntExpectExpression (L.Token L.Lexeme) (Maybe (L.Token L.Lexeme)) | TypeDeclarationErrors [UF.Error v Ann] + -- MissingTypeModifier (type|ability) name + | MissingTypeModifier (L.Token String) (L.Token v) | ResolutionFailures [Names.ResolutionFailure v Ann] | DuplicateTypeNames [(v, [Ann])] | DuplicateTermNames [(v, [Ann])] @@ -108,27 +127,8 @@ data Error v | FloatPattern Ann deriving (Show, Eq, Ord) -data Ann - = Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos } - | External - | Ann { start :: L.Pos, end :: L.Pos } - deriving (Eq, Ord, Show) - -startingLine :: Ann -> Maybe L.Line -startingLine (Ann (L.line -> line) _) = Just line -startingLine _ = Nothing - -instance Monoid Ann where - mempty = External - mappend = (<>) - -instance Semigroup Ann where - Ann s1 _ <> Ann _ e2 = Ann s1 e2 - -- If we have a concrete location from a file, use it - External <> a = a - a <> External = a - Intrinsic <> a = a - a <> Intrinsic = a +instance (Ord v, Show v) => ShowErrorComponent (Error v) where + showErrorComponent e = show e tokenToPair :: L.Token a -> (Ann, a) tokenToPair t = (ann t, L.payload t) @@ -411,24 +411,22 @@ string = queryToken getString getString _ = Nothing tupleOrParenthesized :: Ord v => P v a -> (Ann -> a) -> (a -> a -> a) -> P v a -tupleOrParenthesized p unit pair = do - open <- openBlockWith "(" - es <- sepBy (reserved "," *> optional semi) p - close <- optional semi *> closeBlock - pure $ go es open close - where - go [t] _ _ = t - go as s e = foldr pair (unit (ann s <> ann e)) as +tupleOrParenthesized p unit pair = seq' "(" go p + where + go _ [t] = t + go a xs = foldr pair (unit a) xs seq :: Ord v => (Ann -> [a] -> a) -> P v a -> P v a -seq f p = f' <$> leading <*> elements <*> trailing - where - f' open elems close = f (ann open <> ann close) elems - redundant = P.skipMany (P.eitherP (reserved ",") semi) - leading = reserved "[" <* redundant - trailing = redundant *> reserved "]" - sep = P.try $ optional semi *> reserved "," <* redundant - elements = sepEndBy sep p +seq = seq' "[" + +seq' :: Ord v => String -> (Ann -> [a] -> a) -> P v a -> P v a +seq' openStr f p = do + open <- openBlockWith openStr <* redundant + es <- sepEndBy (P.try $ optional semi *> reserved "," <* redundant) p + close <- redundant *> closeBlock + pure $ go open es close + where go open elems close = f (ann open <> ann close) elems + redundant = P.skipMany (P.eitherP (reserved ",") semi) chainr1 :: Ord v => P v a -> P v (a -> a -> a) -> P v a chainr1 p op = go1 where diff --git a/parser-typechecker/src/Unison/Parser/Ann.hs b/parser-typechecker/src/Unison/Parser/Ann.hs new file mode 100644 index 0000000000..5a0d089725 --- /dev/null +++ b/parser-typechecker/src/Unison/Parser/Ann.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Parser.Ann where + +import qualified Unison.Lexer.Pos as L + +data Ann + = Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos } + | External + | Ann {start :: L.Pos, end :: L.Pos} + deriving (Eq, Ord, Show) + +startingLine :: Ann -> Maybe L.Line +startingLine (Ann (L.line -> line) _) = Just line +startingLine _ = Nothing + +instance Monoid Ann where + mempty = External + mappend = (<>) + +instance Semigroup Ann where + Ann s1 _ <> Ann _ e2 = Ann s1 e2 + -- If we have a concrete location from a file, use it + External <> a = a + a <> External = a + Intrinsic <> a = a + a <> Intrinsic = a diff --git a/parser-typechecker/src/Unison/Parsers.hs b/parser-typechecker/src/Unison/Parsers.hs index be787c3d1d..07d04024ba 100644 --- a/parser-typechecker/src/Unison/Parsers.hs +++ b/parser-typechecker/src/Unison/Parsers.hs @@ -8,7 +8,7 @@ import Prelude hiding ( readFile ) import qualified Unison.Names3 as Names import qualified Unison.Builtin as Builtin import qualified Unison.FileParser as FileParser -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Parser as Parser import Unison.PrintError ( prettyParseError , defaultWidth ) diff --git a/parser-typechecker/src/Unison/Path.hs b/parser-typechecker/src/Unison/Path.hs deleted file mode 100644 index 5ce88ed774..0000000000 --- a/parser-typechecker/src/Unison/Path.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | --- Provides a typeclass for a general concept of a path into --- a treelike structure. We have a root or empty path, paths --- may be concatenated, and a pair of paths may be factored into --- paths relative to their lowest common ancestor in the tree. - -module Unison.Path where - -import Unison.Prelude - --- | Satisfies: --- * `extend root p == p` and `extend p root == p` --- * `extend` is associative, `extend (extend p1 p2) p3 == extend p1 (extend p2 p3)` --- * `lca root p == root` and `lca p root == root` --- * `case factor p p2 of (r,p',p2') -> extend r p' == p && extend r p2' == p2` -class Path p where - -- | The root or empty path - root :: p - -- | Concatenate two paths - extend :: p -> p -> p - -- | Extract the lowest common ancestor and the path from the LCA to each argument - factor :: p -> p -> (p,(p,p)) - -- | Satisfies `factor (parent p) p == (parent p, (root, tl)` and - -- `extend (parent p) tl == p` - parent :: p -> p - --- | Compute the lowest common ancestor of two paths -lca :: Path p => p -> p -> p -lca p p2 = fst (factor p p2) - --- | `isSubpath p1 p2` is true if `p2 == extend p1 x` for some `x` -isSubpath :: (Eq p, Path p) => p -> p -> Bool -isSubpath p1 p2 = lca p1 p2 == p1 - -instance Eq a => Path (Maybe a) where - root = Nothing - extend = (<|>) - parent _ = Nothing - factor p1 p2 | p1 == p2 = (p1, (Nothing, Nothing)) - factor p1 p2 = (Nothing, (p1,p2)) - -instance Eq a => Path [a] where - root = [] - extend = (++) - parent p | null p = [] - parent p = init p - factor p1 p2 = (take shared p1, (drop shared p1, drop shared p2)) - where shared = length (takeWhile id $ zipWith (==) p1 p2) - -instance Path () where - root = () - parent _ = () - extend _ _ = () - factor u _ = (u,(u,u)) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index 3b1f0cc2c3..2cbb87c293 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -1,23 +1,16 @@ {-# Language OverloadedStrings #-} -module Unison.PrettyPrintEnv where +module Unison.PrettyPrintEnv (PrettyPrintEnv(..), patterns, patternName, termName, typeName) where import Unison.Prelude import Unison.HashQualified ( HashQualified ) import Unison.Name ( Name ) -import Unison.Names3 ( Names ) import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) -import Unison.Util.List (safeHead) -import qualified Data.Map as Map import qualified Unison.HashQualified as HQ -import qualified Unison.Name as Name -import qualified Unison.Names3 as Names -import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.ConstructorType as CT -import qualified Data.Set as Set data PrettyPrintEnv = PrettyPrintEnv { -- names for terms, constructors, and requests @@ -32,69 +25,12 @@ patterns ppe r cid = terms ppe (Referent.Con r cid CT.Data) instance Show PrettyPrintEnv where show _ = "PrettyPrintEnv" -fromNames :: Int -> Names -> PrettyPrintEnv -fromNames len names = PrettyPrintEnv terms' types' where - terms' r = shortestName . Set.map Name.convert $ Names.termName len r names - types' r = shortestName . Set.map Name.convert $ Names.typeName len r names - shortestName ns = safeHead $ HQ.sortByLength (toList ns) - -fromSuffixNames :: Int -> Names -> PrettyPrintEnv -fromSuffixNames len names = PrettyPrintEnv terms' types' where - terms' r = safeHead $ Names.suffixedTermName len r names - types' r = safeHead $ Names.suffixedTypeName len r names - -fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl -fromNamesDecl len names = - PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) - --- A pair of PrettyPrintEnvs: --- - suffixifiedPPE uses the shortest unique suffix --- - unsuffixifiedPPE uses the shortest full name --- --- Generally, we want declarations LHS (the `x` in `x = 23`) to use the --- unsuffixified names, so the LHS is an accurate description of where in the --- namespace the definition lives. For everywhere else, we can use the --- suffixified version. -data PrettyPrintEnvDecl = PrettyPrintEnvDecl { - unsuffixifiedPPE :: PrettyPrintEnv, - suffixifiedPPE :: PrettyPrintEnv - } deriving Show - --- declarationPPE uses the full name for references that are --- part the same cycle as the input reference, used to ensures --- recursive definitions are printed properly, for instance: --- --- foo.bar x = foo.bar x --- and not --- foo.bar x = bar x -declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv -declarationPPE ppe rd = PrettyPrintEnv tm ty where - comp = Reference.members (Reference.componentFor rd) - tm r0@(Referent.Ref r) = if Set.member r comp - then terms (unsuffixifiedPPE ppe) r0 - else terms (suffixifiedPPE ppe) r0 - tm r = terms (suffixifiedPPE ppe) r - ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r - else types (suffixifiedPPE ppe) r - -- Left-biased union of environments unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv unionLeft e1 e2 = PrettyPrintEnv (\r -> terms e1 r <|> terms e2 r) (\r -> types e1 r <|> types e2 r) -assignTermName - :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv -assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) - -fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv -fromTypeNames types = - let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) - -fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv -fromTermNames tms = - let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) - -- todo: these need to be a dynamic length, but we need additional info todoHashLength :: Int todoHashLength = 10 @@ -118,25 +54,3 @@ instance Monoid PrettyPrintEnv where mappend = unionLeft instance Semigroup PrettyPrintEnv where (<>) = mappend - --- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' --- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. - --- Note that a Suffix can include dots. -type Suffix = Text --- Each member of a Prefix list is dot-free. -type Prefix = [Text] --- Keys are FQNs, values are shorter names which are equivalent, thanks to use --- statements that are in scope. -type Imports = Map Name Suffix - --- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. -elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name -elideFQN imports hq = - let hash = HQ.toHash hq - name' = do name <- HQ.toName hq - let hit = fmap Name.unsafeFromText (Map.lookup name imports) - -- Cut out the "const id $" to get tracing of FQN elision attempts. - let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) - t (pure $ fromMaybe name hit) - in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs new file mode 100644 index 0000000000..18c9c20774 --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs @@ -0,0 +1,32 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Unison.HashQualified as HQ +import Unison.Name (Name) +import qualified Unison.Name as Name + +-- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' +-- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. + +-- Note that a Suffix can include dots. +type Suffix = Text +-- Each member of a Prefix list is dot-free. +type Prefix = [Text] +-- Keys are FQNs, values are shorter names which are equivalent, thanks to use +-- statements that are in scope. +type Imports = Map Name Suffix + +-- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. +elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name +elideFQN imports hq = + let hash = HQ.toHash hq + name' = do name <- HQ.toName hq + let hit = fmap Name.unsafeFromText (Map.lookup name imports) + -- Cut out the "const id $" to get tracing of FQN elision attempts. + let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) + t (pure $ fromMaybe name hit) + in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs new file mode 100644 index 0000000000..43416c3637 --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs @@ -0,0 +1,24 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) where + +import Unison.Prelude + +import qualified Data.Set as Set +import qualified Unison.HashQualified as HQ +import qualified Unison.Name as Name +import Unison.Names3 (Names) +import qualified Unison.Names3 as Names +import Unison.PrettyPrintEnv (PrettyPrintEnv (PrettyPrintEnv)) +import Unison.Util.List (safeHead) + +fromNames :: Int -> Names -> PrettyPrintEnv +fromNames len names = PrettyPrintEnv terms' types' where + terms' r = shortestName . Set.map Name.convert $ Names.termName len r names + types' r = shortestName . Set.map Name.convert $ Names.typeName len r names + shortestName ns = safeHead $ HQ.sortByLength (toList ns) + +fromSuffixNames :: Int -> Names -> PrettyPrintEnv +fromSuffixNames len names = PrettyPrintEnv terms' types' where + terms' r = safeHead $ Names.suffixedTermName len r names + types' r = safeHead $ Names.suffixedTypeName len r names diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs new file mode 100644 index 0000000000..f7dbff52e4 --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Unison.PrettyPrintEnv.Util (declarationPPE, declarationPPEDecl) where + +import qualified Data.Set as Set +import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (suffixifiedPPE, unsuffixifiedPPE)) +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent + +-- declarationPPE uses the full name for references that are +-- part the same cycle as the input reference, used to ensures +-- recursive definitions are printed properly, for instance: +-- +-- foo.bar x = foo.bar x +-- and not +-- foo.bar x = bar x +declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv +declarationPPE ppe rd = PrettyPrintEnv tm ty + where + comp = Reference.members (Reference.componentFor rd) + tm r0@(Referent.Ref r) = + if Set.member r comp + then terms (unsuffixifiedPPE ppe) r0 + else terms (suffixifiedPPE ppe) r0 + tm r = terms (suffixifiedPPE ppe) r + ty r = + if Set.member r comp + then types (unsuffixifiedPPE ppe) r + else types (suffixifiedPPE ppe) r + +-- The suffixed names uses the fully-qualified name for `r` +declarationPPEDecl :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnvDecl +declarationPPEDecl ppe r = + ppe { suffixifiedPPE = declarationPPE ppe r } \ No newline at end of file diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs new file mode 100644 index 0000000000..340fae4c78 --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs @@ -0,0 +1,19 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl(..)) where + +import Unison.PrettyPrintEnv (PrettyPrintEnv(..)) + +-- A pair of PrettyPrintEnvs: +-- - suffixifiedPPE uses the shortest unique suffix +-- - unsuffixifiedPPE uses the shortest full name +-- +-- Generally, we want declarations LHS (the `x` in `x = 23`) to use the +-- unsuffixified names, so the LHS is an accurate description of where in the +-- namespace the definition lives. For everywhere else, we can use the +-- suffixified version. +data PrettyPrintEnvDecl = PrettyPrintEnvDecl { + unsuffixifiedPPE :: PrettyPrintEnv, + suffixifiedPPE :: PrettyPrintEnv + } deriving Show + diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs new file mode 100644 index 0000000000..dedb5591bd --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs @@ -0,0 +1,11 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnvDecl.Names where + +import Unison.Names3 (Names) +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl)) +import Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) + +fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl +fromNamesDecl len names = + PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index e2c219b0e1..898c0c66dd 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -25,8 +25,9 @@ import Unison.Kind (Kind) import qualified Unison.Kind as Kind import qualified Unison.Lexer as L import Unison.Name ( Name ) -import Unison.Parser (Ann (..), Annotated, ann) -import qualified Unison.Parser as Parser +import Unison.Parser (Annotated, ann) +import qualified Unison.Parser as Parser +import Unison.Parser.Ann (Ann (..)) import qualified Unison.Reference as R import Unison.Referent (Referent, pattern Ref) import Unison.Result (Note (..)) @@ -37,7 +38,7 @@ import qualified Unison.Type as Type import qualified Unison.Typechecker.Context as C import Unison.Typechecker.TypeError import qualified Unison.Typechecker.TypeVar as TypeVar -import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Error as UF import Unison.Util.AnnotatedText (AnnotatedText) import qualified Unison.Util.AnnotatedText as AT import Unison.Util.ColorText (Color) @@ -50,7 +51,7 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.TermPrinter as TermPrinter import qualified Unison.Util.Pretty as Pr import Unison.Util.Pretty (Pretty, ColorText) -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name import Unison.HashQualified (HashQualified) import Unison.Type (Type) @@ -69,6 +70,10 @@ pattern Identifier = Color.Bold defaultWidth :: Pr.Width defaultWidth = 60 +-- Various links used in error messages, collected here for a quick overview +structuralVsUniqueDocsLink :: IsString a => Pretty a +structuralVsUniqueDocsLink = "https://www.unisonweb.org/docs/language-reference/#unique-types" + fromOverHere' :: Ord a => String @@ -359,6 +364,30 @@ renderTypeError e env src = case e of ] , debugSummary note ] + AbilityCheckFailure {..} + | [tv@(Type.Var' ev)] <- ambient + , ev `Set.member` foldMap Type.freeVars requested -> mconcat + [ "I tried to infer a cyclic ability." + , "\n\n" + , "The expression " + , describeStyle ErrorSite + , " was inferred to require the " + , case length requested of + 1 -> "ability: " + _ -> "abilities: " + , "\n\n {" + , commas (renderType' env) requested + , "}" + , "\n\n" + , "where `" + , renderType' env tv + , "` is its overall abilities." + , "\n\n" + , "I need a type signature to help figure this out." + , "\n\n" + , annotatedAsErrorSite src abilityCheckFailureSite + , debugSummary note + ] AbilityCheckFailure {..} | C.InSubtype{} :<| _ <- C.path note -> mconcat [ "The expression " @@ -1002,6 +1031,10 @@ prettyParseError s = \case where excerpt = showSource s ((\t -> (rangeForToken t, ErrorSite)) <$> ts) go = \case + L.UnexpectedDelimiter s -> + "I found a " <> style ErrorSite (fromString s) <> + " here, but I didn't see a list or tuple that it might be a separator for.\n\n" <> + excerpt L.CloseWithoutMatchingOpen open close -> "I found a closing " <> style ErrorSite (fromString close) <> " here without a matching " <> style ErrorSite (fromString open) <> ".\n\n" <> @@ -1287,6 +1320,15 @@ prettyParseError s = \case missing = Set.null referents go (Parser.ResolutionFailures failures) = Pr.border 2 . prettyResolutionFailures s $ failures + go (Parser.MissingTypeModifier keyword name) = Pr.lines + [ Pr.wrap $ + "I expected to see `structural` or `unique` at the start of this line:" + , "" + , tokensAsErrorSite s [void keyword, void name] + , Pr.wrap $ "Learn more about when to use `structural` vs `unique` in the Unison Docs: " + <> structuralVsUniqueDocsLink + ] + unknownConstructor :: String -> L.Token (HashQualified Name) -> Pretty ColorText unknownConstructor ctorType tok = Pr.lines [ diff --git a/parser-typechecker/src/Unison/Result.hs b/parser-typechecker/src/Unison/Result.hs index c0569c9113..cd592ae34d 100644 --- a/parser-typechecker/src/Unison/Result.hs +++ b/parser-typechecker/src/Unison/Result.hs @@ -19,7 +19,7 @@ import Unison.Paths ( Path ) import Unison.Term ( Term ) import qualified Unison.Typechecker.Context as Context import Control.Error.Util ( note) -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names type Result notes = ResultT notes Identity diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index cc0f4cf458..163f6cd14e 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -101,9 +101,9 @@ import Unison.Typechecker.Components (minimize') import Unison.Pattern (SeqOp(..)) import qualified Unison.Pattern as P import Unison.Reference (Reference(..)) -import Unison.Referent (Referent, pattern Ref, pattern Con) +import Unison.Referent (Referent) --- For internal errors +-- For internal errors data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) deriving (Show) instance Exception CompileExn @@ -751,7 +751,8 @@ data POp | EQLU | CMPU | EROR -- Code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load - | VALU -- value + | CVLD -- validate + | VALU | TLTT -- value, Term.Link.toText -- Debug | PRNT | INFO -- STM @@ -1021,8 +1022,8 @@ anfBlock (Match' scrut cas) = do , pure . TMatch r $ MatchDataCover Ty.seqViewRef (EC.mapFromList - [ (0, ([], em)) - , (1, ([BX,BX], bd)) + [ (toEnum Ty.seqViewEmpty, ([], em)) + , (toEnum Ty.seqViewElem, ([BX,BX], bd)) ] ) ) @@ -1205,12 +1206,8 @@ contLinks f (Mark ps de k) contLinks _ KE = mempty litLinks :: Monoid a => (Bool -> Reference -> a) -> BLit -> a -litLinks _ (Text _) = mempty -litLinks _ (Bytes _) = mempty litLinks f (List s) = foldMap (valueLinks f) s -litLinks f (TmLink (Ref r)) = f False r -litLinks f (TmLink (Con r _ _)) = f True r -litLinks f (TyLink r) = f True r +litLinks _ _ = mempty groupTermLinks :: SuperGroup v -> [Reference] groupTermLinks = Set.toList . groupLinks f diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index 741d5a57ea..189cce769c 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -483,7 +483,7 @@ putBranches ctx bs = case bs of putTag MReqT putMap putReference (putEnumMap putCTag (putCase ctx)) m putNormal (v:ctx) df - where + where MatchData r m df -> do putTag MDataT putReference r @@ -528,7 +528,7 @@ getCase ctx frsh0 = do let l = length ccs frsh = frsh0 + fromIntegral l us = getFresh <$> take l [frsh0..] - (,) ccs <$> getNormal (us++ctx) frsh + (,) ccs . TAbss us <$> getNormal (us++ctx) frsh putCTag :: MonadPut m => CTag -> m () putCTag c = serialize (VarInt $ fromEnum c) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index a226ec2a04..13700356b1 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -18,6 +18,9 @@ module Unison.Runtime.Builtin ) where import Control.Monad.State.Strict (State, modify, execState) +import qualified Control.Exception.Safe as Exception +import Control.Monad.Catch (MonadCatch) +import Control.DeepSeq (NFData) import Unison.ABT.Normalized hiding (TTm) import Unison.Reference @@ -32,7 +35,6 @@ import Unison.Runtime.Foreign ( Foreign(Wrap), HashAlgorithm(..), pattern Failure) import qualified Unison.Runtime.Foreign as F import Unison.Runtime.Foreign.Function -import Unison.Runtime.IOSource (eitherReference) import qualified Unison.Type as Ty import qualified Unison.Builtin as Ty (builtinTypes) @@ -58,7 +60,7 @@ import Data.PEM (pemContent, pemParseLBS, PEM) import Data.Set (insert) import qualified Data.Map as Map -import Unison.Prelude +import Unison.Prelude hiding (some) import qualified Unison.Util.Bytes as Bytes import Network.Socket as SYS ( accept @@ -77,6 +79,12 @@ import Network.Simple.TCP as SYS import Network.TLS as TLS import Network.TLS.Extra.Cipher as Cipher +import Data.IORef as SYS + ( IORef + , newIORef + , readIORef + , writeIORef + ) import System.IO as SYS ( IOMode(..) , openFile @@ -176,6 +184,17 @@ fls, tru :: Var v => ANormal v fls = TCon Ty.booleanRef 0 [] tru = TCon Ty.booleanRef 1 [] +none :: Var v => ANormal v +none = TCon Ty.optionalRef (toEnum Ty.noneId) [] +some, left, right :: Var v => v -> ANormal v +some a = TCon Ty.optionalRef (toEnum Ty.someId) [a] +left x = TCon Ty.eitherRef (toEnum Ty.eitherLeftId) [x] +right x = TCon Ty.eitherRef (toEnum Ty.eitherRightId) [x] +seqViewEmpty :: Var v => ANormal v +seqViewEmpty = TCon Ty.seqViewRef (toEnum Ty.seqViewEmpty) [] +seqViewElem :: Var v => v -> v -> ANormal v +seqViewElem l r = TCon Ty.seqViewRef (toEnum Ty.seqViewElem) [l,r] + boolift :: Var v => v -> ANormal v boolift v = TMatch v $ MatchIntegral (mapFromList [(0,fls), (1,tru)]) Nothing @@ -434,24 +453,24 @@ sizet = unop0 1 $ \[x,r] unconst = unop0 7 $ \[x,t,c0,c,y,p,u,yp] -> TLetD t UN (TPrm UCNS [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN,BX], TAbss [c0,y] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD yp BX (TCon Ty.pairRef 0 [y,u]) . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD p BX (TCon Ty.pairRef 0 [c,yp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] unsnoct = unop0 7 $ \[x,t,c0,c,y,p,u,cp] -> TLetD t UN (TPrm USNC [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([BX,UN], TAbss [y,c0] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD cp BX (TCon Ty.pairRef 0 [c,u]) . TLetD p BX (TCon Ty.pairRef 0 [y,cp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] appends, conss, snocs :: Var v => SuperNormal v @@ -478,8 +497,8 @@ ats = binop0 3 $ \[x0,y,x,t,r] -> unbox x0 Ty.natRef x . TLetD t UN (TPrm IDXS [x,y]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) + [ (0, ([], none)) + , (1, ([BX], TAbs r $ some r)) ] emptys = Lambda [] $ TPrm BLDS [] @@ -487,14 +506,14 @@ viewls, viewrs :: Var v => SuperNormal v viewls = unop0 3 $ \[s,u,h,t] -> TLetD u UN (TPrm VWLS [s]) . TMatch u . MatchSum $ mapFromList - [ (0, ([], TCon Ty.seqViewRef 0 [])) - , (1, ([BX,BX], TAbss [h,t] $ TCon Ty.seqViewRef 1 [h,t])) + [ (0, ([], seqViewEmpty)) + , (1, ([BX,BX], TAbss [h,t] $ seqViewElem h t)) ] viewrs = unop0 3 $ \[s,u,i,l] -> TLetD u UN (TPrm VWRS [s]) . TMatch u . MatchSum $ mapFromList - [ (0, ([], TCon Ty.seqViewRef 0 [])) - , (1, ([BX,BX], TAbss [i,l] $ TCon Ty.seqViewRef 1 [i,l])) + [ (0, ([], seqViewEmpty)) + , (1, ([BX,BX], TAbss [i,l] $ seqViewElem i l)) ] eqt, neqt, leqt, geqt, lesst, great :: Var v => SuperNormal v @@ -545,10 +564,10 @@ atb = binop0 4 $ \[n0,b,n,t,r0,r] -> unbox n0 Ty.natRef n . TLetD t UN (TPrm IDXB [n,b]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs r0 . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ TCon Ty.optionalRef 1 [r])) + $ some r)) ] sizeb = unop0 1 $ \[b,n] @@ -572,26 +591,26 @@ t2i, t2n, t2f :: Var v => SuperNormal v t2i = unop0 3 $ \[x,t,n0,n] -> TLetD t UN (TPrm TTOI [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs n0 . TLetD n BX (TCon Ty.intRef 0 [n0]) - $ TCon Ty.optionalRef 1 [n])) + $ some n)) ] t2n = unop0 3 $ \[x,t,n0,n] -> TLetD t UN (TPrm TTON [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs n0 . TLetD n BX (TCon Ty.natRef 0 [n0]) - $ TCon Ty.optionalRef 1 [n])) + $ some n)) ] t2f = unop0 3 $ \[x,t,f0,f] -> TLetD t UN (TPrm TTOF [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs f0 . TLetD f BX (TCon Ty.floatRef 0 [f0]) - $ TCon Ty.optionalRef 1 [f])) + $ some f)) ] equ :: Var v => SuperNormal v @@ -661,9 +680,23 @@ cast ri ro -> unbox x0 ri x $ TCon ro 0 [x] +-- This version of unsafeCoerce is the identity function. It works +-- only if the two types being coerced between are actually the same, +-- because it keeps the same representation. It is not capable of +-- e.g. correctly translating between two types with compatible bit +-- representations, because tagging information will be retained. +poly'coerce :: Var v => SuperNormal v +poly'coerce = unop0 0 $ \[x] -> TVar x + jumpk :: Var v => SuperNormal v jumpk = binop0 0 $ \[k,a] -> TKon k [a] +scope'run :: Var v => SuperNormal v +scope'run + = unop0 1 $ \[e, un] + -> TLetD un BX (TCon Ty.unitRef 0 []) + $ TApp (FVar e) [un] + fork'comp :: Var v => SuperNormal v fork'comp = Lambda [BX] @@ -714,17 +747,35 @@ code'lookup = unop0 2 $ \[link,t,r] -> TLetD t UN (TPrm LKUP [link]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) + [ (0, ([], none)) + , (1, ([BX], TAbs r $ some r)) ] +code'validate :: Var v => SuperNormal v +code'validate + = unop0 5 $ \[item, t, ref, msg, extra, fail] + -> TLetD t UN (TPrm CVLD [item]) + . TMatch t . MatchSum + $ mapFromList + [ (1, ([BX, BX, BX],) + . TAbss [ref, msg, extra] + . TLetD fail BX (TCon Ty.failureRef 0 [ref, msg, extra]) + $ some fail) + , (0, ([],) + $ none) + ] + +term'link'to'text :: Var v => SuperNormal v +term'link'to'text + = unop0 0 $ \[link] -> TPrm TLTT [link] + value'load :: Var v => SuperNormal v value'load = unop0 2 $ \[vlu,t,r] -> TLetD t UN (TPrm LOAD [vlu]) . TMatch t . MatchSum $ mapFromList - [ (0, ([BX], TAbs r $ TCon Ty.eitherRef 0 [r])) - , (1, ([BX], TAbs r $ TCon Ty.eitherRef 1 [r])) + [ (0, ([BX], TAbs r $ left r)) + , (1, ([BX], TAbs r $ right r)) ] value'create :: Var v => SuperNormal v @@ -751,6 +802,17 @@ standard'handle instr where (h0,h) = fresh2 +any'construct :: Var v => SuperNormal v +any'construct + = unop0 0 $ \[v] + -> TCon Ty.anyRef 0 [v] + +any'extract :: Var v => SuperNormal v +any'extract + = unop0 1 + $ \[v,v1] -> TMatch v + $ MatchData Ty.anyRef (mapSingleton 0 $ ([BX], TAbs v1 (TVar v1))) Nothing + seek'handle :: ForeignOp seek'handle instr = ([BX,BX,BX],) @@ -876,9 +938,9 @@ inMaybeBx arg1 arg2 arg3 mb result cont instr = . TAbss [arg1, arg2] . TMatch arg1 . flip (MatchData Ty.optionalRef) Nothing $ mapFromList - [ (0, ([], TLetD mb UN (TLit $ I 0) + [ (toEnum Ty.noneId, ([], TLetD mb UN (TLit $ I 0) $ TLetD result UN (TFOp instr [mb, arg2]) cont)) - , (1, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) + , (toEnum Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) ] -- a -> b -> ... @@ -918,20 +980,20 @@ inBxIomr arg1 arg2 fm result cont instr outMaybe :: forall v. Var v => v -> v -> ANormal v outMaybe maybe result = TMatch result . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs maybe $ TCon Ty.optionalRef 1 [maybe])) + [ (0, ([], none)) + , (1, ([BX], TAbs maybe $ some maybe)) ] outMaybeTup :: forall v. Var v => v -> v -> v -> v -> v -> v -> v -> ANormal v outMaybeTup a b n u bp p result = TMatch result . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN,BX], TAbss [a,b] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD bp BX (TCon Ty.pairRef 0 [b,u]) . TLetD n BX (TCon Ty.natRef 0 [a]) . TLetD p BX (TCon Ty.pairRef 0 [n,bp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] outIoFail :: forall v. Var v => v -> v -> v -> v -> ANormal v @@ -940,8 +1002,8 @@ outIoFail stack1 stack2 fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) - , (1, ([BX], TAbs stack1 $ TCon eitherReference 1 [stack1])) + $ left fail) + , (1, ([BX], TAbs stack1 $ right stack1)) ] outIoFailNat :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -950,11 +1012,11 @@ outIoFailNat stack1 stack2 stack3 fail nat result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([UN],) . TAbs stack3 . TLetD nat BX (TCon Ty.natRef 0 [stack3]) - $ TCon eitherReference 1 [nat]) + $ right nat) ] outIoFailBox :: forall v. Var v => v -> v -> v -> v -> ANormal v @@ -963,10 +1025,10 @@ outIoFailBox stack1 stack2 fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([BX],) . TAbs stack1 - $ TCon eitherReference 1 [stack1]) + $ right stack1) ] outIoFailUnit :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -976,11 +1038,11 @@ outIoFailUnit stack1 stack2 stack3 unit fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([BX],) . TAbss [stack3] . TLetD unit BX (TCon Ty.unitRef 0 []) - $ TCon eitherReference 1 [unit]) + $ right unit) ] outIoFailBool :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -990,11 +1052,11 @@ outIoFailBool stack1 stack2 stack3 bool fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([UN],) . TAbs stack3 . TLet (Indirect 1) bool BX (boolift stack3) - $ TCon eitherReference 1 [bool]) + $ right bool) ] outIoFailG @@ -1006,9 +1068,9 @@ outIoFailG stack1 stack2 fail result output k [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, k $ \t -> TLetD output BX t - $ TCon eitherReference 1 [output]) + $ right output) ] -- Input / Output glue @@ -1041,6 +1103,12 @@ unitToEFNat = inUnit unit result $ outIoFailNat stack1 stack2 stack3 fail nat result where (unit, stack1, stack2, stack3, fail, nat, result) = fresh7 +-- () -> Int +unitToInt :: ForeignOp +unitToInt = inUnit unit result + $ TCon Ty.intRef 0 [result] + where (unit, result) = fresh2 + -- () -> Either Failure a unitToEFBox :: ForeignOp unitToEFBox = inUnit unit result @@ -1070,10 +1138,10 @@ boxBoxTo0 instr (arg1, arg2) = fresh2 -- Nat -> () -natToUnit :: ForeignOp -natToUnit = inNat arg nat result (TCon Ty.unitRef 0 []) - where - (arg, nat, result) = fresh3 +-- natToUnit :: ForeignOp +-- natToUnit = inNat arg nat result (TCon Ty.unitRef 0 []) +-- where +-- (arg, nat, result) = fresh3 -- a -> Bool boxToBool :: ForeignOp @@ -1141,8 +1209,8 @@ boxToEFMBox = inBx arg result . outIoFailG stack1 stack2 fail result output $ \k -> ([UN], TAbs stack3 . TMatch stack3 . MatchSum $ mapFromList - [ (0, ([], k $ TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs stack4 . k $ TCon Ty.optionalRef 1 [stack4])) + [ (0, ([], k $ none)) + , (1, ([BX], TAbs stack4 . k $ some stack4)) ]) where (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh8 @@ -1213,12 +1281,29 @@ boxBoxToEFBox = inBxBx arg1 arg2 result where (arg1, arg2, result, stack1, stack2, fail) = fresh6 --- a -> Nat -> Either Failure +-- a -> Nat -> Either Failure b boxNatToEFBox :: ForeignOp boxNatToEFBox = inBxNat arg1 arg2 nat result $ outIoFail stack1 stack2 fail result where (arg1, arg2, nat, stack1, stack2, fail, result) = fresh7 +-- Nat -> Either Failure () +natToEFUnit :: ForeignOp +natToEFUnit + = inNat arg nat result + . TMatch result . MatchSum $ mapFromList + [ (0, ([BX, BX],) + . TAbss [stack1, stack2] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) + $ left fail) + , (1, ([],) + . TLetD unit BX (TCon Ty.unitRef 0 []) + $ right unit) + + ] + where + (arg, nat, result, fail, stack1, stack2, unit) = fresh7 + -- a -> Either b c boxToEBoxBox :: ForeignOp boxToEBoxBox instr @@ -1227,8 +1312,8 @@ boxToEBoxBox instr . TLetD e UN (TFOp instr [b]) . TMatch e . MatchSum $ mapFromList - [ (0, ([BX], TAbs ev $ TCon eitherReference 0 [ev])) - , (1, ([BX], TAbs ev $ TCon eitherReference 1 [ev])) + [ (0, ([BX], TAbs ev $ left ev)) + , (1, ([BX], TAbs ev $ right ev)) ] where (e,b,ev) = fresh3 @@ -1369,6 +1454,7 @@ builtinLookup , ("bug", bug "builtin.bug") , ("todo", bug "builtin.todo") , ("Debug.watch", watch) + , ("unsafe.coerceAbilities", poly'coerce) , ("Char.toNat", cast Ty.charRef Ty.natRef) , ("Char.fromNat", cast Ty.natRef Ty.charRef) @@ -1408,12 +1494,17 @@ builtinLookup , ("IO.forkComp.v2", fork'comp) + , ("Scope.run", scope'run) + , ("Code.isMissing", code'missing) , ("Code.cache_", code'cache) , ("Code.lookup", code'lookup) + , ("Code.validate", code'validate) , ("Value.load", value'load) , ("Value.value", value'create) - + , ("Any.Any", any'construct) + , ("Any.unsafeExtract", any'extract) + , ("Link.Term.toText", term'link'to'text) , ("STM.atomically", stm'atomic) ] ++ foreignWrappers @@ -1490,9 +1581,13 @@ declareForeigns = do $ \(h,n) -> Bytes.fromArray <$> hGet h n declareForeign "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h,bs) -> hPut h (Bytes.toArray bs) + declareForeign "IO.systemTime.impl.v3" unitToEFNat $ mkForeignIOF $ \() -> getPOSIXTime + declareForeign "IO.systemTimeMicroseconds.v1" unitToInt + $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime + declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox $ mkForeignIOF $ \() -> getTemporaryDirectory @@ -1572,7 +1667,8 @@ declareForeigns = do declareForeign "IO.kill.impl.v3" boxTo0 $ mkForeignIOF killThread - declareForeign "IO.delay.impl.v3" natToUnit $ mkForeignIOF threadDelay + declareForeign "IO.delay.impl.v3" natToEFUnit + $ mkForeignIOF threadDelay declareForeign "IO.stdHandle" standard'handle . mkForeign $ \(n :: Int) -> case n of @@ -1611,6 +1707,7 @@ declareForeigns = do declareForeign "MVar.tryRead.impl.v3" boxToEFMBox . mkForeignIOF $ \(mv :: MVar Closure) -> tryReadMVar mv + declareForeign "Char.toText" (wordDirect Ty.charRef) . mkForeign $ \(ch :: Char) -> pure (Text.singleton ch) @@ -1670,6 +1767,19 @@ declareForeigns = do declareForeign "STM.retry" unitDirect . mkForeign $ \() -> unsafeSTMToIO STM.retry :: IO Closure + -- Scope and Ref stuff + declareForeign "Scope.ref" boxDirect + . mkForeign $ \(c :: Closure) -> newIORef c + + declareForeign "IO.ref" boxDirect + . mkForeign $ \(c :: Closure) -> newIORef c + + declareForeign "Ref.read" boxDirect . mkForeign $ + \(r :: IORef Closure) -> readIORef r + + declareForeign "Ref.write" boxBoxTo0 . mkForeign $ + \(r :: IORef Closure, c :: Closure) -> writeIORef r c + let defaultSupported :: TLS.Supported defaultSupported = def { TLS.supportedCiphers = Cipher.ciphersuite_strong } @@ -1734,6 +1844,8 @@ declareForeigns = do -> pure . Bytes.fromArray $ serializeGroup sg declareForeign "Code.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeGroup @Symbol . Bytes.toArray + declareForeign "Code.display" boxBoxDirect . mkForeign + $ \(nm,sg) -> pure $ prettyGroup @Symbol (Text.unpack nm) sg "" declareForeign "Value.dependencies" boxDirect . mkForeign $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks @@ -1741,10 +1853,6 @@ declareForeigns = do . mkForeign $ pure . Bytes.fromArray . serializeValue declareForeign "Value.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeValue . Bytes.toArray - - declareForeign "Any.Any" boxDirect . mkForeign $ \(a :: Closure) -> - pure $ Closure.DataB1 Ty.anyRef 0 a - -- Hashing functions let declareHashAlgorithm :: forall v alg . Var v => Hash.HashAlgorithm alg => Text -> alg -> FDecl v () declareHashAlgorithm txt alg = do @@ -1795,6 +1903,21 @@ declareForeigns = do in pure . Bytes.fromArray . hmac alg $ serializeValueLazy x + let + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Text.pack (show se)) + Right a -> Right a + + declareForeign "Bytes.zlib.compress" boxDirect . mkForeign $ pure . Bytes.zlibCompress + declareForeign "Bytes.gzip.compress" boxDirect . mkForeign $ pure . Bytes.gzipCompress + declareForeign "Bytes.zlib.decompress" boxToEBoxBox . mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + declareForeign "Bytes.gzip.decompress" boxToEBoxBox . mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + declareForeign "Bytes.toBase16" boxDirect . mkForeign $ pure . Bytes.toBase16 declareForeign "Bytes.toBase32" boxDirect . mkForeign $ pure . Bytes.toBase32 declareForeign "Bytes.toBase64" boxDirect . mkForeign $ pure . Bytes.toBase64 diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index dc7720495d..0991b74e29 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -17,6 +17,7 @@ module Unison.Runtime.Foreign ) where import Control.Concurrent (ThreadId, MVar) +import Data.IORef (IORef) import Data.Text (Text, unpack) import Data.Tagged (Tagged(..)) import Network.Socket (Socket) @@ -47,6 +48,8 @@ ref2eq r -- Note: MVar equality is just reference equality, so it shouldn't -- matter what type the MVar holds. | r == Ty.mvarRef = Just $ promote ((==) @(MVar ())) + -- Ditto + | r == Ty.refRef = Just $ promote ((==) @(IORef ())) | otherwise = Nothing ref2cmp :: Reference -> Maybe (a -> b -> Ordering) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs index 09b86eeda0..826f938357 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs @@ -18,6 +18,7 @@ import Control.Concurrent.MVar (MVar) import Control.Concurrent.STM (TVar) import Control.Exception (evaluate) import qualified Data.Char as Char +import Data.IORef (IORef) import Data.Foldable (toList) import Data.Text (Text, pack, unpack) import Data.Time.Clock.POSIX (POSIXTime) @@ -28,7 +29,7 @@ import System.IO (BufferMode(..), SeekMode, Handle, IOMode) import Unison.Util.Bytes (Bytes) import Unison.Reference (Reference) -import Unison.Type (mvarRef, tvarRef, typeLinkRef) +import Unison.Type (mvarRef, tvarRef, typeLinkRef, refRef) import Unison.Symbol (Symbol) import Unison.Runtime.ANF (SuperGroup, Mem(..), Value, internalBug) @@ -348,6 +349,10 @@ instance ForeignConvention (TVar Closure) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap tvarRef) +instance ForeignConvention (IORef Closure) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap refRef) + instance ForeignConvention (SuperGroup Symbol) where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index 44f97a3b36..9a07526fb7 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -14,12 +14,13 @@ import Data.List (elemIndex, genericIndex) import Text.RawString.QQ (r) import Unison.Codebase.CodeLookup (CodeLookup(..)) import Unison.FileParsers (parseAndSynthesizeFile) -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import Unison.Symbol (Symbol) import qualified Data.Map as Map import qualified Unison.Builtin as Builtin -import qualified Unison.Codebase.CodeLookup as CL +import qualified Unison.Codebase.CodeLookup.Util as CL import qualified Unison.DataDeclaration as DD +import qualified Unison.DataDeclaration.ConstructorId as DD import qualified Unison.Parser as Parser import qualified Unison.Reference as R import qualified Unison.Result as Result @@ -55,7 +56,7 @@ termNamed s = fromMaybe (error $ "No builtin term called: " <> s) $ Map.lookup (Var.nameds s) typecheckedFileTerms codeLookup :: CodeLookup Symbol Identity Ann -codeLookup = CL.fromUnisonFile $ UF.discardTypes typecheckedFile +codeLookup = CL.fromTypecheckedUnisonFile typecheckedFile typeNamedId :: String -> R.Id typeNamedId s = @@ -152,6 +153,7 @@ pattern Doc2Table ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2TableId - pattern Doc2Folded isFolded d d2 <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2FoldedId -> True)) [Term.Boolean' isFolded, d, d2] pattern Doc2Paragraph ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ParagraphId -> True)) (Term.List' (toList -> ds)) pattern Doc2BulletedList ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BulletedListId -> True)) (Term.List' (toList -> ds)) +pattern Doc2NumberedList n ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NumberedListId -> True)) [Term.Nat' n, Term.List' (toList -> ds)] pattern Doc2Section title ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2SectionId -> True)) [title, Term.List' (toList -> ds)] pattern Doc2NamedLink name dest <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NamedLinkId -> True)) [name, dest] pattern Doc2Image alt link caption <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2ImageId -> True)) [alt, link, caption] @@ -295,9 +297,9 @@ constructorName ref cid = source :: Text source = fromString [r| -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b -type Optional a = None | Some a +structural type Optional a = None | Some a unique[b28d929d0a73d2c18eac86341a3bb9399f8550c11b5f35eabb2751e6803ccc20] type IsPropagated = IsPropagated @@ -462,7 +464,7 @@ unique[d7b2ced8c08b2c6e54050d1f5acedef3395f293d] type Pretty.Annotated w txt | Indent w (Pretty.Annotated w txt) (Pretty.Annotated w txt) (Pretty.Annotated w txt) | Append w [Pretty.Annotated w txt] -type Pretty txt = Pretty (Pretty.Annotated () txt) +structural type Pretty txt = Pretty (Pretty.Annotated () txt) Pretty.get = cases Pretty p -> p diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 5f151cae05..b95496dd79 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -46,7 +46,7 @@ import Unison.Codebase.CodeLookup (CodeLookup(..)) import Unison.Codebase.Runtime (Runtime(..), Error) import Unison.Codebase.MainTerm (builtinMain, builtinTest) -import Unison.Parser (Ann(External)) +import Unison.Parser.Ann (Ann(External)) import Unison.PrettyPrintEnv import Unison.Util.Pretty as P import Unison.Symbol (Symbol) @@ -63,6 +63,7 @@ import Unison.Runtime.Machine ) import Unison.Runtime.Pattern import Unison.Runtime.Stack +import qualified Unison.Hashing.V2.Convert as Hashing type Term v = Tm.Term v () @@ -254,12 +255,12 @@ prepareEvaluation ppe tm ctx = do (rmn, rtms) | Tm.LetRecNamed' bs mn0 <- tm , hcs <- fmap (first RF.DerivedId) - . Tm.hashComponents $ Map.fromList bs + . Hashing.hashTermComponents $ Map.fromList bs , mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0 - , rmn <- RF.DerivedId $ Tm.hashClosedTerm mn + , rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn = (rmn , (rmn, mn) : Map.elems hcs) - | rmn <- RF.DerivedId $ Tm.hashClosedTerm tm + | rmn <- RF.DerivedId $ Hashing.hashClosedTerm tm = (rmn, [(rmn, tm)]) (rgrp, rbkr) = intermediateTerms ppe ctx rtms @@ -355,5 +356,4 @@ startRuntime = do evalInContext ppe ctx init , mainType = builtinMain External , ioTestType = builtinTest External - , needsContainment = False } diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs index 27152f4c0b..640b0978e2 100644 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ b/parser-typechecker/src/Unison/Runtime/MCode.hs @@ -330,7 +330,8 @@ data BPrim1 | FLTB -- flatten -- code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load - | VALU -- value + | CVLD -- validate + | VALU | TLTT -- value, Term.Link.toText deriving (Show, Eq, Ord) data BPrim2 @@ -741,7 +742,7 @@ emitSection rns grpn rec ctx (TMatch v bs) | Just (i,BX) <- ctxResolve ctx v , MatchData r cs df <- bs = Ins (Unpack (Just r) i) - <$> emitDataMatching rns grpn rec ctx cs df + <$> emitDataMatching r rns grpn rec ctx cs df | Just (i,BX) <- ctxResolve ctx v , MatchRequest hs0 df <- bs , hs <- mapFromList $ first (dnum rns) <$> M.toList hs0 @@ -1057,6 +1058,8 @@ emitPOp ANF.CMPU = emitBP2 CMPU emitPOp ANF.MISS = emitBP1 MISS emitPOp ANF.CACH = emitBP1 CACH emitPOp ANF.LKUP = emitBP1 LKUP +emitPOp ANF.TLTT = emitBP1 TLTT +emitPOp ANF.CVLD = emitBP1 CVLD emitPOp ANF.LOAD = emitBP1 LOAD emitPOp ANF.VALU = emitBP1 VALU @@ -1121,21 +1124,22 @@ emitBP2 p a emitDataMatching :: Var v - => RefNums + => Reference + -> RefNums -> Word64 -> RCtx v -> Ctx v -> EnumMap CTag ([Mem], ANormal v) -> Maybe (ANormal v) -> Emit Section -emitDataMatching rns grpn rec ctx cs df +emitDataMatching r rns grpn rec ctx cs df = MatchW 0 <$> edf <*> traverse (emitCase rns grpn rec ctx) (coerce cs) where -- Note: this is not really accurate. A default data case needs -- stack space corresponding to the actual data that shows up there. -- However, we currently don't use default cases for data. edf | Just co <- df = emitSection rns grpn rec ctx co - | otherwise = countCtx ctx $ Die "missing data case" + | otherwise = countCtx ctx $ Die ("missing data case for hash " <> show r) -- Emits code corresponding to an unboxed sum match. -- The match is against a tag on the stack, and cases introduce diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 0c5764e54f..ad85451634 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -15,7 +15,7 @@ import GHC.Conc as STM (unsafeIOToSTM) import Data.Maybe (fromMaybe) import Data.Bits -import Data.Foldable (toList) +import Data.Foldable (toList, traverse_) import Data.Traversable import Data.Word (Word64) @@ -33,13 +33,14 @@ import qualified Data.Primitive.PrimArray as PA import Text.Read (readMaybe) -import Unison.Builtin.Decls (exceptionRef) -import Unison.Reference (Reference(Builtin)) +import Unison.Builtin.Decls (exceptionRef, ioFailureRef) +import Unison.Reference (Reference(Builtin), toShortHash) import Unison.Referent (pattern Ref) +import qualified Unison.ShortHash as SH import Unison.Symbol (Symbol) import Unison.Runtime.ANF - as ANF (Mem(..), SuperGroup, valueLinks, groupLinks) + as ANF (Mem(..), CompileExn(..), SuperGroup, valueLinks, groupLinks) import qualified Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin import Unison.Runtime.Exception @@ -51,6 +52,7 @@ import Unison.Runtime.MCode import qualified Unison.Type as Rf import qualified Unison.Util.Bytes as By +import Unison.Util.Pretty (toPlainUnbroken) import Unison.Util.EnumContainers as EC type Tag = Word64 @@ -216,8 +218,25 @@ exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do unknown <- cacheAdd news env bstk <- bump bstk pokeS bstk - (Sq.fromList $ Foreign . Wrap Rf.typeLinkRef . Ref <$> unknown) + (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, ustk, bstk, k) +exec !env !denv !ustk !bstk !k (BPrim1 CVLD i) = do + arg <- peekOffS bstk i + news <- decodeCacheArgument arg + codeValidate news env >>= \case + Nothing -> do + ustk <- bump ustk + poke ustk 0 + pure (denv, ustk, bstk, k) + Just (Failure ref msg clo) -> do + ustk <- bump ustk + bstk <- bumpn bstk 3 + poke ustk 1 + poke bstk (Foreign $ Wrap Rf.typeLinkRef ref) + pokeOffBi bstk 1 msg + pokeOff bstk 2 clo + pure (denv, ustk, bstk, k) + exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do clink <- peekOff bstk i let Ref link = unwrapForeign $ marshalToForeign clink @@ -230,6 +249,13 @@ exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do bstk <- bump bstk bstk <$ pokeBi bstk sg pure (denv, ustk, bstk, k) +exec !_ !denv !ustk !bstk !k (BPrim1 TLTT i) = do + clink <- peekOff bstk i + let Ref link = unwrapForeign $ marshalToForeign clink + let sh = SH.toText $ toShortHash link + bstk <- bump bstk + pokeBi bstk sh + pure (denv, ustk, bstk, k) exec !env !denv !ustk !bstk !k (BPrim1 LOAD i) = do v <- peekOffBi bstk i ustk <- bump ustk @@ -1179,6 +1205,8 @@ bprim1 !ustk !bstk FLTB i = do bprim1 !ustk !bstk MISS _ = pure (ustk, bstk) bprim1 !ustk !bstk CACH _ = pure (ustk, bstk) bprim1 !ustk !bstk LKUP _ = pure (ustk, bstk) +bprim1 !ustk !bstk CVLD _ = pure (ustk, bstk) +bprim1 !ustk !bstk TLTT _ = pure (ustk, bstk) bprim1 !ustk !bstk LOAD _ = pure (ustk, bstk) bprim1 !ustk !bstk VALU _ = pure (ustk, bstk) {-# inline bprim1 #-} @@ -1449,7 +1477,9 @@ decodeCacheArgument :: Sq.Seq Closure -> IO [(Reference, SuperGroup Symbol)] decodeCacheArgument s = for (toList s) $ \case DataB2 _ _ (Foreign x) (DataB2 _ _ (Foreign y) _) - -> pure (unwrapForeign x, unwrapForeign y) + -> case unwrapForeign x of + Ref r -> pure (r, unwrapForeign y) + _ -> die "decodeCacheArgument: Con reference" _ -> die "decodeCacheArgument: unrecognized value" addRefs @@ -1470,6 +1500,30 @@ addRefs vfrsh vfrom vto rs = do modifyTVar vto (nto <>) pure from +codeValidate + :: [(Reference, SuperGroup Symbol)] + -> CCache + -> IO (Maybe (Failure Closure)) +codeValidate tml cc = do + rty0 <- readTVarIO (refTy cc) + fty <- readTVarIO (freshTy cc) + let f b r | b, M.notMember r rty0 = S.singleton r + | otherwise = mempty + ntys0 = (foldMap.foldMap) (groupLinks f) tml + ntys = M.fromList $ zip (S.toList ntys0) [fty..] + rty = ntys <> rty0 + ftm <- readTVarIO (freshTm cc) + rtm0 <- readTVarIO (refTm cc) + let (rs, gs) = unzip tml + rtm = rtm0 `M.withoutKeys` S.fromList rs + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) + combinate (n, g) = evaluate $ emitCombs rns n g + (Nothing <$ traverse_ combinate (zip [ftm..] gs)) + `catch` \(CE cs perr) -> let + msg = Tx.pack $ toPlainUnbroken perr + extra = Foreign . Wrap Rf.textRef . Tx.pack $ show cs in + pure . Just $ Failure ioFailureRef msg extra + cacheAdd0 :: S.Set Reference -> [(Reference, SuperGroup Symbol)] @@ -1480,6 +1534,7 @@ cacheAdd0 ntys0 tml cc = atomically $ do let new = M.difference toAdd have sz = fromIntegral $ M.size new (rs,gs) = unzip $ M.toList new + int <- writeTVar (intermed cc) (have <> new) rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 ntm <- stateTVar (freshTm cc) $ \i -> (i, i+sz) rtm <- updateMap (M.fromList $ zip rs [ntm..]) (refTm cc) @@ -1488,7 +1543,7 @@ cacheAdd0 ntys0 tml cc = atomically $ do combinate n g = (n, emitCombs rns n g) nrs <- updateMap (mapFromList $ zip [ntm..] rs) (combRefs cc) ncs <- updateMap (mapFromList $ zipWith combinate [ntm..] gs) (combs cc) - pure $ rtm `seq` nrs `seq` ncs `seq` () + pure $ int `seq` rtm `seq` nrs `seq` ncs `seq` () where toAdd = M.fromList tml @@ -1552,7 +1607,7 @@ reflectValue rty = goV = pure (ANF.TmLink l) | Just l <- maybeUnwrapForeign Rf.typeLinkRef f = pure (ANF.TyLink l) - | otherwise = die $ err "foreign value" + | otherwise = die $ err $ "foreign value: " <> (show f) reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Closure) diff --git a/parser-typechecker/src/Unison/Runtime/Pattern.hs b/parser-typechecker/src/Unison/Runtime/Pattern.hs index 5da3afbea3..f3ac9bd960 100644 --- a/parser-typechecker/src/Unison/Runtime/Pattern.hs +++ b/parser-typechecker/src/Unison/Runtime/Pattern.hs @@ -25,6 +25,7 @@ import Unison.ABT (absChain', visitPure, pattern AbsN', renames) import Unison.Builtin.Decls (builtinDataDecls, builtinEffectDecls) import Unison.DataDeclaration (declFields) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Pattern import qualified Unison.Pattern as P import Unison.Reference (Reference(..)) @@ -350,7 +351,7 @@ splitRowSeq -> [([P.Pattern v], PatternRow v)] splitRowSeq avoid0 v m r@(PR (break ((==v).loc) -> (pl, sp : pr)) g b) = case decomposeSeqP avoid m sp of - Cover sps -> + Cover sps -> [(sps, PR (pl ++ filter refutable sps ++ pr) g b)] Disjoint -> [] Overlap -> [([], r)] @@ -553,7 +554,7 @@ prepareAs p u = pure $ u <$ p preparePattern :: Var v => P.Pattern a -> PPM v (P.Pattern v) preparePattern p = prepareAs p =<< freshVar -buildPattern :: Bool -> Reference -> Int -> [v] -> Int -> P.Pattern () +buildPattern :: Bool -> Reference -> ConstructorId -> [v] -> Int -> P.Pattern () buildPattern effect r t vs nfields | effect, [] <- vps = internalBug "too few patterns for effect bind" | effect = P.EffectBind () r t (init vps) (last vps) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 529244330e..1fe1090523 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -32,6 +32,8 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch, Branch0) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch +import qualified Unison.Codebase.Causal (RawHash(RawHash)) import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Metadata as Metadata import Unison.Codebase.Path (Path) @@ -58,9 +60,11 @@ import Unison.Names3 Names0, ) import qualified Unison.Names3 as Names3 -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.PrettyPrintEnvDecl.Names as PPE import Unison.Reference (Reference) import qualified Unison.Reference as Reference import Unison.Referent (Referent) @@ -86,8 +90,12 @@ import qualified Unison.Util.Star3 as Star3 import qualified Unison.Util.SyntaxText as UST import Unison.Var (Var) import qualified Unison.Server.Doc as Doc -import qualified Unison.UnisonFile as UF import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject +import qualified Unison.WatchKind as WK +import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.Hashing.V2.Convert as Hashing + +type SyntaxText = UST.SyntaxText' Reference data ShallowListEntry v a = ShallowTermEntry (TermEntry v a) @@ -251,6 +259,35 @@ findShallow codebase path' = do Nothing -> pure [] Just b -> findShallowInBranch codebase b +findShallowReadmeInBranchAndRender :: + Var v => + Width -> + Rt.Runtime v -> + Codebase IO v Ann -> + Branch IO -> + Backend IO (Maybe Doc.Doc) +findShallowReadmeInBranchAndRender width runtime codebase branch = + let ppe hqLen = PPE.fromNamesDecl hqLen printNames + + printNames = getCurrentPrettyNames (Path.fromList []) branch + + renderReadme ppe r = do + res <- renderDoc ppe width runtime codebase (Referent.toReference r) + pure $ case res of + (_, _, doc) : _ -> Just doc + _ -> Nothing + + -- allow any of these capitalizations + toCheck = NameSegment <$> ["README", "Readme", "ReadMe", "readme" ] + readmes :: Set Referent + readmes = foldMap lookup toCheck + where lookup seg = R.lookupRan seg rel + rel = Star3.d1 (Branch._terms (Branch.head branch)) + in do + hqLen <- liftIO $ Codebase.hashLength codebase + join <$> traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes) + + termListEntry :: Monad m => Var v @@ -287,7 +324,7 @@ typeListEntry codebase r n = do pure $ case decl of Just (Left _) -> Ability _ -> Data - _ -> pure Data + _ -> pure (if Set.member r Type.builtinAbilities then Ability else Data) pure $ TypeEntry r n tag typeDeclHeader @@ -315,7 +352,7 @@ formatTypeName :: PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText formatTypeName ppe = fmap Syntax.convertElement . formatTypeName' ppe -formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> UST.SyntaxText +formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> SyntaxText formatTypeName' ppe r = Pretty.renderUnbroken . NP.styleHashQualified id $ @@ -326,7 +363,7 @@ termEntryToNamedTerm termEntryToNamedTerm ppe typeWidth (TermEntry r name mayType tag) = NamedTerm { termName = HQ'.toText name , termHash = Referent.toText r - , termType = formatType ppe (mayDefault typeWidth) <$> mayType + , termType = formatType ppe (mayDefaultWidth typeWidth) <$> mayType , termTag = tag } @@ -556,7 +593,7 @@ expandShortBranchHash codebase hash = do _ -> throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet -formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> UST.SyntaxText +formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = Pretty.render w . TypePrinter.pretty0 ppe mempty (-1) @@ -603,14 +640,14 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod parseNames = getCurrentParseNames (fromMaybe Path.empty relativeTo) branch ppe = PPE.fromNamesDecl hqLength printNames - width = mayDefault renderWidth + width = mayDefaultWidth renderWidth isAbsolute (Name.toText -> n) = "." `Text.isPrefixOf` n && n /= "." termFqns :: Map Reference (Set Text) termFqns = Map.mapWithKey f terms where rel = Names.terms $ currentNames parseNames f k _ = Set.fromList . fmap Name.toText . filter isAbsolute . toList - $ R.lookupRan (Referent.Ref' k) rel + $ R.lookupRan (Referent.Ref k) rel typeFqns :: Map Reference (Set Text) typeFqns = Map.mapWithKey f types where @@ -631,34 +668,6 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod _ -> pure [] pure [ r | (r, t) <- rts, Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref) ] - renderDoc :: Reference -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] - renderDoc r = do - let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r) - let hash = Reference.toText r - map (name,hash,) . pure <$> - let tm = Term.ref () r - in Doc.renderDoc @v ppe terms typeOf eval decls tm - where - terms r@(Reference.Builtin _) = pure (Just (Term.ref () r)) - terms (Reference.DerivedId r) = - fmap Term.unannotate <$> lift (Codebase.getTerm codebase r) - - typeOf r = fmap void <$> lift (Codebase.getTypeOfReferent codebase r) - eval (Term.amap (const mempty) -> tm) = do - let ppes = PPE.suffixifiedPPE ppe - let codeLookup = Codebase.toCodeLookup codebase - let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r - r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm - lift $ case r of - Just tmr -> Codebase.putWatch codebase UF.RegularWatch - (Term.hashClosedTerm tm) - (Term.amap (const mempty) tmr) - Nothing -> pure () - pure $ r <&> Term.amap (const mempty) - - decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> lift (Codebase.getTypeDeclaration codebase r) - decls _ = pure Nothing - -- rs0 can be empty or the term fetched, so when viewing a doc term -- you get both its source and its rendered form docResults :: [Reference] -> [Name] -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] @@ -668,7 +677,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod -- lookup the type of each, make sure it's a doc docs <- selectDocs (toList rs) -- render all the docs - join <$> traverse renderDoc docs + join <$> traverse (renderDoc ppe width rt codebase) docs mkTermDefinition r tm = do ts <- lift (Codebase.getTypeOfTerm codebase r) @@ -712,6 +721,46 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod renderedDisplayTypes renderedMisses +renderDoc :: + forall v. + Var v => + PPE.PrettyPrintEnvDecl -> + Width -> + Rt.Runtime v -> + Codebase IO v Ann -> + Reference -> + Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] +renderDoc ppe width rt codebase r = do + let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r) + let hash = Reference.toText r + map (name,hash,) . pure + <$> let tm = Term.ref () r + in Doc.renderDoc @v ppe terms typeOf eval decls tm + where + terms r@(Reference.Builtin _) = pure (Just (Term.ref () r)) + terms (Reference.DerivedId r) = + fmap Term.unannotate <$> lift (Codebase.getTerm codebase r) + + typeOf r = fmap void <$> lift (Codebase.getTypeOfReferent codebase r) + eval (Term.amap (const mempty) -> tm) = do + let ppes = PPE.suffixifiedPPE ppe + let codeLookup = Codebase.toCodeLookup codebase + let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r + r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm + lift $ case r of + Just tmr -> + Codebase.putWatch + codebase + WK.RegularWatch + (Hashing.hashClosedTerm tm) + (Term.amap (const mempty) tmr) + Nothing -> pure () + pure $ r <&> Term.amap (const mempty) + + decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> lift (Codebase.getTypeDeclaration codebase r) + decls _ = pure Nothing + + bestNameForTerm :: forall v . Var v => PPE.PrettyPrintEnv -> Width -> Referent -> Text bestNameForTerm ppe width = @@ -730,14 +779,25 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () -resolveBranchHash - :: Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) +resolveBranchHash :: + Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) resolveBranchHash h codebase = case h of - Nothing -> getRootBranch codebase + Nothing -> getRootBranch codebase Just bhash -> do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash mayBranch ?? NoBranchForHash bhash + +resolveRootBranchHash :: + Monad m => Maybe ShortBranchHash -> Codebase m v Ann -> Backend m (Branch m) +resolveRootBranchHash mayRoot codebase = case mayRoot of + Nothing -> + getRootBranch codebase + Just sbh -> do + h <- expandShortBranchHash codebase sbh + resolveBranchHash (Just h) codebase + + definitionsBySuffixes :: forall m v . (MonadIO m) @@ -800,7 +860,7 @@ termsToSyntax -> Width -> PPE.PrettyPrintEnvDecl -> Map Reference.Reference (DisplayObject (Type v a) (Term v a)) - -> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText) + -> Map Reference.Reference (DisplayObject SyntaxText SyntaxText) termsToSyntax suff width ppe0 terms = Map.fromList . map go . Map.toList $ Map.mapKeys (first (PPE.termName ppeDecl . Referent.Ref) . dupe) @@ -825,15 +885,12 @@ typesToSyntax -> Width -> PPE.PrettyPrintEnvDecl -> Map Reference.Reference (DisplayObject () (DD.Decl v a)) - -> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText) + -> Map Reference.Reference (DisplayObject SyntaxText SyntaxText) typesToSyntax suff width ppe0 types = Map.fromList $ map go . Map.toList $ Map.mapKeys (first (PPE.typeName ppeDecl) . dupe) types where - ppeBody r = if suffixified suff - then PPE.suffixifiedPPE ppe0 - else PPE.declarationPPE ppe0 r ppeDecl = if suffixified suff then PPE.suffixifiedPPE ppe0 else PPE.unsuffixifiedPPE ppe0 @@ -841,7 +898,7 @@ typesToSyntax suff width ppe0 types = BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) MissingObject sh -> MissingObject sh UserObject d -> UserObject . Pretty.render width $ - DeclPrinter.prettyDecl (ppeBody r) r n d + DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d loadSearchResults :: (Var v, Applicative m) diff --git a/parser-typechecker/src/Unison/Server/CodebaseServer.hs b/parser-typechecker/src/Unison/Server/CodebaseServer.hs index b7644e2baa..6c4e1f9335 100644 --- a/parser-typechecker/src/Unison/Server/CodebaseServer.hs +++ b/parser-typechecker/src/Unison/Server/CodebaseServer.hs @@ -78,14 +78,15 @@ import qualified System.FilePath as FilePath import System.Random.Stateful (getStdGen, newAtomicGenM, uniformByteStringM) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Runtime as Rt -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Endpoints.GetDefinitions ( DefinitionsAPI, serveDefinitions, ) -import Unison.Server.Endpoints.ListNamespace (NamespaceAPI, serveNamespace) +import qualified Unison.Server.Endpoints.NamespaceDetails as NamespaceDetails +import qualified Unison.Server.Endpoints.NamespaceListing as NamespaceListing import Unison.Server.Types (mungeString) import Unison.Var (Var) @@ -104,7 +105,12 @@ type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw -type UnisonAPI = NamespaceAPI :<|> DefinitionsAPI :<|> FuzzyFindAPI +type UnisonAPI = + NamespaceListing.NamespaceListingAPI + :<|> NamespaceDetails.NamespaceDetailsAPI + :<|> DefinitionsAPI + :<|> FuzzyFindAPI + type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml @@ -270,30 +276,28 @@ serveIndex path = do serveUI :: Handler () -> FilePath -> Server WebUI serveUI tryAuth path _ = tryAuth *> serveIndex path -server - :: Var v - => Rt.Runtime v - -> Codebase IO v Ann - -> FilePath - -> Strict.ByteString - -> Server AuthedServerAPI +server :: + Var v => + Rt.Runtime v -> + Codebase IO v Ann -> + FilePath -> + Strict.ByteString -> + Server AuthedServerAPI server rt codebase uiPath token = serveDirectoryWebApp (uiPath "static") - :<|> ((\t -> - serveUI (tryAuth t) uiPath - :<|> ( ( (serveNamespace (tryAuth t) codebase) - :<|> (serveDefinitions (tryAuth t) rt codebase) - :<|> (serveFuzzyFind (tryAuth t) codebase) - ) - :<|> serveOpenAPI - :<|> Tagged serveDocs - ) - ) + :<|> ( \token -> + serveUI (tryAuth token) uiPath + :<|> unisonApi token + :<|> serveOpenAPI + :<|> Tagged serveDocs ) - - where - serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS - serveOpenAPI = pure openAPI - plain = ("Content-Type", "text/plain") - tryAuth = handleAuth token - + where + serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS + serveOpenAPI = pure openAPI + plain = ("Content-Type", "text/plain") + tryAuth = handleAuth token + unisonApi t = + NamespaceListing.serve (tryAuth t) codebase + :<|> NamespaceDetails.serve (tryAuth t) rt codebase + :<|> serveDefinitions (tryAuth t) rt codebase + :<|> serveFuzzyFind (tryAuth t) codebase diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index 3dc21f3716..df7e40e807 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -34,6 +34,7 @@ import qualified Unison.DataDeclaration as DD import qualified Unison.DeclPrinter as DeclPrinter import qualified Unison.NamePrinter as NP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.Runtime.IOSource as DD @@ -48,6 +49,8 @@ import qualified Unison.Util.SyntaxText as S type Nat = Word64 +type SSyntaxText = S.SyntaxText' Reference + data Doc = Word Text | Code Doc @@ -135,6 +138,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case DD.Doc2Folded isFolded d d2 -> Folded isFolded <$> go d <*> go d2 DD.Doc2Paragraph ds -> Paragraph <$> traverse go ds DD.Doc2BulletedList ds -> BulletedList <$> traverse go ds + DD.Doc2NumberedList n ds -> NumberedList n <$> traverse go ds DD.Doc2Section title ds -> Section <$> go title <*> traverse go ds DD.Doc2NamedLink d1 d2 -> NamedLink <$> go d1 <*> go d2 DD.Doc2Image d1 d2 Decls.OptionalNone' -> Image <$> go d1 <*> go d2 <*> pure Nothing @@ -153,7 +157,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case source :: Term v () -> m SyntaxText source tm = (pure . formatPretty . TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped)) tm - goSignatures :: [Referent] -> m [P.Pretty S.SyntaxText] + goSignatures :: [Referent] -> m [P.Pretty SSyntaxText] goSignatures rs = runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case Nothing -> pure ["πŸ†˜ codebase is missing type signature for these definitions"] Just types -> pure . fmap P.group $ @@ -184,9 +188,9 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case -- Link (Either Link.Type Doc2.Term) DD.Doc2SpecialFormLink e -> let ppe = PPE.suffixifiedPPE pped - tm :: Referent -> P.Pretty S.SyntaxText + tm :: Referent -> P.Pretty SSyntaxText tm r = (NP.styleHashQualified'' (NP.fmt (S.Referent r)) . PPE.termName ppe) r - ty :: Reference -> P.Pretty S.SyntaxText + ty :: Reference -> P.Pretty SSyntaxText ty r = (NP.styleHashQualified'' (NP.fmt (S.Reference r)) . PPE.typeName ppe) r in Link <$> case e of DD.EitherLeft' (Term.TypeLink' r) -> (pure . formatPretty . ty) r @@ -241,7 +245,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case Just decl -> pure $ DO.UserObject (Src folded full) where - full = formatPretty (DeclPrinter.prettyDecl ppe r (PPE.typeName ppe r) decl) + full = formatPretty (DeclPrinter.prettyDecl pped r (PPE.typeName ppe r) decl) folded = formatPretty (DeclPrinter.prettyDeclHeader (PPE.typeName ppe r) decl) go :: (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)]) diff --git a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs index f8dd84cac7..4f789998a6 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -34,10 +34,11 @@ import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.HashQualified' as HQ' import Unison.NameSegment -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend import Unison.Server.Errors @@ -52,7 +53,7 @@ import Unison.Server.Types NamedTerm, NamedType, addHeaders, - mayDefault, + mayDefaultWidth, ) import Unison.Util.Pretty (Width) import Unison.Var (Var) @@ -161,7 +162,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = ( a , FoundTermResult . FoundTerm - (Backend.bestNameForTerm @v ppe (mayDefault typeWidth) r) + (Backend.bestNameForTerm @v ppe (mayDefaultWidth typeWidth) r) $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) @@ -169,7 +170,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = Backend.FoundTypeRef r -> do te <- Backend.typeListEntry codebase r n let namedType = Backend.typeEntryToNamedType te - let typeName = Backend.bestNameForType @v ppe (mayDefault typeWidth) r + let typeName = Backend.bestNameForType @v ppe (mayDefaultWidth typeWidth) r typeHeader <- Backend.typeDeclHeader codebase ppe r let ft = FoundType typeName typeHeader namedType pure (a, FoundTypeResult ft) diff --git a/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs b/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs index f7cb3b18c5..7b20ee0b7c 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs @@ -24,12 +24,13 @@ import Servant.Docs import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash ( ShortBranchHash, ) import qualified Unison.HashQualified as HQ -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend import Unison.Server.Errors diff --git a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs new file mode 100644 index 0000000000..ae60d760b3 --- /dev/null +++ b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Unison.Server.Endpoints.NamespaceDetails where + +import Control.Error (runExceptT) +import Data.Aeson +import Data.OpenApi (ToSchema) +import qualified Data.Text as Text +import Servant (Capture, QueryParam, throwError, (:>)) +import Servant.Docs (DocCapture (..), ToCapture (..), ToSample (..)) +import Servant.OpenApi () +import Servant.Server (Handler) +import Unison.Codebase (Codebase) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Path as Path +import Unison.Codebase.Path.Parse (parsePath') +import qualified Unison.Codebase.Runtime as Rt +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import qualified Unison.Server.Backend as Backend +import Unison.Server.Doc (Doc) +import Unison.Server.Errors (backendError, badNamespace) +import Unison.Server.Types + ( APIGet, + APIHeaders, + NamespaceFQN, + UnisonHash, + UnisonName, + addHeaders, + branchToUnisonHash, + mayDefaultWidth, + ) +import Unison.Util.Pretty (Width) +import Unison.Var (Var) + +type NamespaceDetailsAPI = + "namespaces" :> Capture "namespace" NamespaceFQN + :> QueryParam "rootBranch" ShortBranchHash + :> QueryParam "renderWidth" Width + :> APIGet NamespaceDetails + +instance ToCapture (Capture "namespace" Text) where + toCapture _ = + DocCapture + "namespace" + "The fully qualified name of a namespace. The leading `.` is optional." + +instance ToSample NamespaceDetails where + toSamples _ = + [ ( "When no value is provided for `namespace`, the root namespace `.` is " + <> "listed by default", + NamespaceDetails + "." + "#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5" + Nothing + ) + ] + +data NamespaceDetails = NamespaceDetails + { fqn :: UnisonName, + hash :: UnisonHash, + readme :: Maybe Doc + } + deriving (Generic, Show) + +instance ToJSON NamespaceDetails where + toEncoding = genericToEncoding defaultOptions + +deriving instance ToSchema NamespaceDetails + +serve :: + Var v => + Handler () -> + Rt.Runtime v -> + Codebase IO v Ann -> + NamespaceFQN -> + Maybe ShortBranchHash -> + Maybe Width -> + Handler (APIHeaders NamespaceDetails) +serve tryAuth runtime codebase namespaceName mayRoot mayWidth = + let doBackend a = do + ea <- liftIO $ runExceptT a + errFromEither backendError ea + + errFromEither f = either (throwError . f) pure + + fqnToPath fqn = do + let fqnS = Text.unpack fqn + path' <- errFromEither (`badNamespace` fqnS) $ parsePath' fqnS + pure (Path.fromPath' path') + + width = mayDefaultWidth mayWidth + in do + namespacePath <- fqnToPath namespaceName + + namespaceDetails <- doBackend $ do + root <- Backend.resolveRootBranchHash mayRoot codebase + let namespaceBranch = Branch.getAt' namespacePath root + readme <- Backend.findShallowReadmeInBranchAndRender width runtime codebase namespaceBranch + + pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme + + addHeaders <$> (tryAuth $> namespaceDetails) diff --git a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs similarity index 94% rename from parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs rename to parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs index 9f06c93e2b..560be33f9d 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Unison.Server.Endpoints.ListNamespace where +module Unison.Server.Endpoints.NamespaceListing where import Control.Error (runExceptT) import Data.Aeson @@ -29,13 +29,12 @@ import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Hash as Hash import qualified Unison.NameSegment as NameSegment -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Server.Backend as Backend @@ -55,13 +54,14 @@ import Unison.Server.Types UnisonHash, UnisonName, addHeaders, + branchToUnisonHash, ) import Unison.Util.Pretty (Width) import Unison.Var (Var) import Control.Error.Util ((??)) -type NamespaceAPI = +type NamespaceListingAPI = "list" :> QueryParam "rootBranch" ShortBranchHash :> QueryParam "relativeTo" NamespaceFQN :> QueryParam "namespace" NamespaceFQN @@ -156,7 +156,7 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name -serveNamespace +serve :: Var v => Handler () -> Codebase IO v Ann @@ -164,7 +164,7 @@ serveNamespace -> Maybe NamespaceFQN -> Maybe NamespaceFQN -> Handler (APIHeaders NamespaceListing) -serveNamespace tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = +serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = let -- Various helpers errFromEither f = either (throwError . f) pure @@ -221,9 +221,9 @@ serveNamespace tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = let shallowPPE = Backend.basicSuffixifiedNames hashLength root $ Path.fromPath' path' let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' - let listingHash = ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash listingBranch + let listingHash = branchToUnisonHash listingBranch listingEntries <- findShallow listingBranch makeNamespaceListing shallowPPE listingFQN listingHash listingEntries in - addHeaders <$> (tryAuth *> namespaceListing) \ No newline at end of file + addHeaders <$> (tryAuth *> namespaceListing) diff --git a/parser-typechecker/src/Unison/Server/Types.hs b/parser-typechecker/src/Unison/Server/Types.hs index e8708e72f5..a5f43a3898 100644 --- a/parser-typechecker/src/Unison/Server/Types.hs +++ b/parser-typechecker/src/Unison/Server/Types.hs @@ -30,6 +30,9 @@ import Unison.Codebase.Editor.DisplayObject ( DisplayObject, ) import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Hash as Hash +import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.ShortBranchHash ( ShortBranchHash (..), ) @@ -207,6 +210,8 @@ instance ToSchema Doc.SpecialForm where instance ToSchema Doc.Src where instance ToSchema a => ToSchema (Doc.Ref a) where +-- Helpers + munge :: Text -> LZ.ByteString munge = Text.encodeUtf8 . Text.fromStrict @@ -222,8 +227,12 @@ defaultWidth = 80 discard :: Applicative m => a -> m () discard = const $ pure () -mayDefault :: Maybe Width -> Width -mayDefault = fromMaybe defaultWidth +mayDefaultWidth :: Maybe Width -> Width +mayDefaultWidth = fromMaybe defaultWidth addHeaders :: v -> APIHeaders v addHeaders = addHeader "*" . addHeader "public" + +branchToUnisonHash :: Branch.Branch m -> UnisonHash +branchToUnisonHash b = + ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash b diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 3103b38675..06bca71fda 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -11,6 +11,7 @@ module Unison.TermParser where import Unison.Prelude import Control.Monad.Reader (asks, local) +import Data.Foldable (foldrM) import Prelude hiding (and, or, seq) import Unison.Name (Name) import Unison.Names3 (Names) @@ -39,6 +40,7 @@ import qualified Unison.Lexer as L import qualified Unison.Name as Name import qualified Unison.Names3 as Names import qualified Unison.Parser as Parser (seq, uniqueName) +import Unison.Parser.Ann (Ann) import qualified Unison.Pattern as Pattern import qualified Unison.Term as Term import qualified Unison.Type as Type @@ -1038,21 +1040,23 @@ block'' isTop implicitUnitAtEnd s openBlock closeBlock = do Right tm -> pure tm toTm bs = do (bs, body) <- body bs - finish $ foldr step body bs + finish =<< foldrM step body bs where - step :: BlockElement v -> Term v Ann -> Term v Ann step elem body = case elem of - Binding ((a,v), tm) -> Term.consLetRec - isTop - (ann a <> ann body) - (a,v,tm) - body - Action tm -> Term.consLetRec - isTop - (ann tm <> ann body) - (ann tm, positionalVar (ann tm) (Var.named "_"), tm) - body - DestructuringBind (_, f) -> f body + Binding ((a,v), tm) -> pure $ + Term.consLetRec + isTop + (ann a <> ann body) + (a,v,tm) + body + Action tm -> pure $ + Term.consLetRec + isTop + (ann tm <> ann body) + (ann tm, positionalVar (ann tm) (Var.named "_"), tm) + body + DestructuringBind (_, f) -> + f <$> finish body body bs = case reverse bs of Binding ((a, _v), _) : _ -> pure $ if implicitUnitAtEnd then (bs, DD.unitTerm a) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 12c3c5a2c1..b8c5bdc511 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -6,47 +6,49 @@ module Unison.TermPrinter where import Unison.Prelude -import Control.Monad.State (evalState) -import qualified Control.Monad.State as State -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Text ( unpack ) -import qualified Data.Text as Text -import qualified Text.Show.Unicode as U -import Data.Vector ( ) -import Unison.ABT ( pattern AbsN', reannotateUp, annotation ) -import qualified Unison.ABT as ABT -import qualified Unison.Blank as Blank -import qualified Unison.HashQualified as HQ -import Unison.Lexer ( symbolyId, showEscapeChar ) -import Unison.Name ( Name ) -import qualified Unison.Name as Name -import qualified Unison.NameSegment as NameSegment -import Unison.NamePrinter ( styleHashQualified'' ) -import qualified Unison.Pattern as Pattern -import Unison.Pattern ( Pattern ) -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import Unison.Referent ( Referent ) -import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText ( SyntaxText ) -import Unison.Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import qualified Unison.TypePrinter as TypePrinter -import Unison.Var ( Var ) -import qualified Unison.Var as Var -import qualified Unison.Util.Bytes as Bytes -import Unison.Util.Monoid ( intercalateMap ) -import qualified Unison.Util.Pretty as PP -import Unison.Util.Pretty ( Pretty, ColorText, Width ) -import Unison.PrettyPrintEnv ( PrettyPrintEnv, Suffix, Prefix, Imports, elideFQN ) -import qualified Unison.PrettyPrintEnv as PrettyPrintEnv -import qualified Unison.Builtin.Decls as DD +import Control.Monad.State (evalState) +import qualified Control.Monad.State as State +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (unpack) +import qualified Data.Text as Text +import Data.Vector () +import qualified Text.Show.Unicode as U +import Unison.ABT (annotation, reannotateUp, pattern AbsN') +import qualified Unison.ABT as ABT +import qualified Unison.Blank as Blank import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm') +import qualified Unison.Builtin.Decls as DD import qualified Unison.ConstructorType as CT +import qualified Unison.HashQualified as HQ +import Unison.Lexer (showEscapeChar, symbolyId) +import Unison.Name (Name) +import qualified Unison.Name as Name +import Unison.NamePrinter (styleHashQualified'') +import qualified Unison.NameSegment as NameSegment +import Unison.Pattern (Pattern) +import qualified Unison.Pattern as Pattern +import Unison.PrettyPrintEnv (PrettyPrintEnv) +import qualified Unison.PrettyPrintEnv as PrettyPrintEnv +import Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent +import Unison.Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.TypePrinter as TypePrinter +import qualified Unison.Util.Bytes as Bytes +import Unison.Util.Monoid (intercalateMap) +import Unison.Util.Pretty (ColorText, Pretty, Width) +import qualified Unison.Util.Pretty as PP +import qualified Unison.Util.SyntaxText as S +import Unison.Var (Var) +import qualified Unison.Var as Var + +type SyntaxText = S.SyntaxText' Reference pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText pretty env = PP.syntaxToColor . pretty0 env emptyAc . printAnnotate env @@ -85,20 +87,20 @@ data BlockContext -- This ABT node is at the top level of a TermParser.block. = Block | Normal - deriving (Eq) + deriving (Eq, Show) data InfixContext -- This ABT node is an infix operator being used in infix position. = Infix | NonInfix - deriving (Eq) + deriving (Eq, Show) data DocLiteralContext -- We won't try and render this ABT node or anything under it as a [: @Doc literal :] = NoDoc -- We'll keep checking as we recurse down | MaybeDoc - deriving (Eq) + deriving (Eq, Show) {- Explanation of precedence handling @@ -210,14 +212,14 @@ pretty0 Just c -> "?\\" ++ [c] Nothing -> '?': [c] Blank' id -> fmt S.Blank $ l "_" <> l (fromMaybe "" (Blank.nameb id)) - Constructor' ref cid -> + Constructor' ref cid -> styleHashQualified'' (fmt $ S.Referent conRef) name - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Data - Request' ref cid -> + Request' ref cid -> styleHashQualified'' (fmt $ S.Referent conRef) name - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Effect Handle' h body -> paren (p >= 2) $ @@ -236,9 +238,13 @@ pretty0 pblock tm = let (im', uses) = calcImports im tm in uses $ [pretty0 n (ac 0 Block im' doc) tm] App' x (Constructor' DD.UnitRef 0) -> - paren (p >= 11) $ (fmt S.DelayForceChar $ l "!") <> pretty0 n (ac 11 Normal im doc) x - Delay' x -> - paren (p >= 11) $ (fmt S.DelayForceChar $ l "'") <> pretty0 n (ac 11 Normal im doc) x + paren (p >= 11 || isBlock x && p >= 3) $ + fmt S.DelayForceChar (l "!") + <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x + Delay' x -> + paren (p >= 11 || isBlock x && p >= 3) $ + fmt S.DelayForceChar (l "'") + <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x List' xs -> PP.group $ (fmt S.DelimiterChar $ l "[") <> optSpace <> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace) @@ -296,7 +302,7 @@ pretty0 -- know bc.) So we'll fail to take advantage of any opportunity -- this let block provides to add a use statement. Not so bad. (fmt S.ControlKeyword "let") `PP.hang` x - lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) (-1) vs pat)) + lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) 10 vs pat)) <> printGuard guard printGuard Nothing = mempty printGuard (Just g') = let (_,g) = ABT.unabs g' in @@ -322,7 +328,7 @@ pretty0 if isDocLiteral term then prettyDoc n im term else pretty0 n (a {docContext = NoDoc}) term - (TupleTerm' [x], _) -> + (TupleTerm' [x], _) -> let conRef = DD.pairCtorRef name = elideFQN im $ PrettyPrintEnv.termName n conRef @@ -331,10 +337,10 @@ pretty0 paren (p >= 10) $ pair `PP.hang` PP.spaced [pretty0 n (ac 10 Normal im doc) x, fmt (S.Referent DD.unitCtorRef) "()" ] - (TupleTerm' xs, _) -> + (TupleTerm' xs, _) -> let tupleLink p = fmt (S.Reference DD.unitRef) p in PP.group (tupleLink "(" <> commaList xs <> tupleLink ")") - + (Bytes' bs, _) -> fmt S.BytesLiteral "0xs" <> (PP.shown $ Bytes.fromWord8s (map fromIntegral bs)) BinaryAppsPred' apps lastArg -> paren (p >= 3) $ @@ -404,21 +410,24 @@ pretty0 -- produce any backticks. We build the result out from the right, -- starting at `f2`. binaryApps - :: Var v => [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] - -> Pretty SyntaxText - -> Pretty SyntaxText + :: Var v + => [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] + -> Pretty SyntaxText + -> Pretty SyntaxText binaryApps xs last = unbroken `PP.orElse` broken - -- todo: use `PP.column2` in the case where we need to break where unbroken = PP.spaced (ps ++ [last]) - broken = PP.column2 (psCols $ [""] ++ ps ++ [last]) + broken = PP.hang (head ps) . PP.column2 . psCols $ (tail ps ++ [last]) psCols ps = case take 2 ps of - [x,y] -> (x,y) : psCols (drop 2 ps) - [] -> [] - _ -> error "??" - ps = join $ [r a f | (a, f) <- reverse xs ] - r a f = [pretty0 n (ac 3 Normal im doc) a, - pretty0 n (AmbientContext 10 Normal Infix im doc False) f] + [x, y] -> (x, y) : psCols (drop 2 ps) + [x] -> [(x, "")] + [] -> [] + _ -> undefined + ps = join $ [ r a f | (a, f) <- reverse xs ] + r a f = + [ pretty0 n (ac (if isBlock a then 12 else 3) Normal im doc) a + , pretty0 n (AmbientContext 10 Normal Infix im doc False) f + ] prettyPattern :: forall v loc . Var v @@ -447,7 +456,7 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of in (PP.parenthesizeCommas pats_printed, tail_vs) Pattern.Constructor _ ref cid [] -> (styleHashQualified'' (fmt $ S.Referent conRef) name, vs) - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Data Pattern.Constructor _ ref cid pats -> @@ -472,7 +481,7 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of conRef = Referent.Con ref cid CT.Effect in ( PP.group ( fmt S.DelimiterChar "{" <> - (PP.sep " " . PP.nonEmpty $ + (PP.sep " " . PP.nonEmpty $ [ styleHashQualified'' (fmt (S.Referent conRef)) $ name , pats_printed , fmt S.ControlKeyword "->" @@ -491,9 +500,9 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of (pr, rvs) = prettyPattern n c (p + 1) lvs r f i s = (paren (p >= i) (pl <> " " <> (fmt (S.Op op) s) <> " " <> pr), rvs) in case op of - Pattern.Cons -> f 9 "+:" - Pattern.Snoc -> f 9 ":+" - Pattern.Concat -> f 9 "++" + Pattern.Cons -> f 0 "+:" + Pattern.Snoc -> f 0 ":+" + Pattern.Concat -> f 0 "++" where l :: IsString s => String -> s l = fromString @@ -1171,6 +1180,15 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)] Pattern.Unbound _ -> False isDestructuringBind _ _ = False +isBlock :: Ord v => Term2 vt at ap v a -> Bool +isBlock tm = + case tm of + If' _ _ _ -> True + Handle' _ _ -> True + Match' _ _ -> True + LetBlock _ _ -> True + _ -> False + pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body)) -- Collects nested let/let rec blocks into one minimally nested block. @@ -1306,6 +1324,16 @@ prettyDoc2 ppe ac tm = case tm of S.DocDelimiter "}}" bail tm = brace (pretty0 ppe ac tm) + -- Finds the longest run of a character and return a run one longer than that + oneMore c inner = replicate num c + where + num = + case + filter (\s -> take 2 s == "__") + $ group (PP.toPlainUnbroken $ PP.syntaxToColor inner) + of + [] -> 2 + x -> 1 + (maximum $ map length x) go :: Width -> Term3 v PrintAnnotation -> Pretty SyntaxText go hdr = \case (toDocTransclude ppe -> Just d) -> @@ -1331,15 +1359,23 @@ prettyDoc2 ppe ac tm = case tm of (toDocWord ppe -> Just t) -> PP.text t (toDocCode ppe -> Just d) -> - PP.group ("''" <> rec d <> "''") + let inner = rec d + quotes = oneMore '\'' inner + in PP.group $ PP.string quotes <> inner <> PP.string quotes (toDocJoin ppe -> Just ds) -> foldMap rec ds (toDocItalic ppe -> Just d) -> - PP.group $ "*" <> rec d <> "*" + let inner = rec d + underscores = oneMore '_' inner + in PP.group $ PP.string underscores <> inner <> PP.string underscores (toDocBold ppe -> Just d) -> - PP.group $ "__" <> rec d <> "__" + let inner = rec d + stars = oneMore '*' inner + in PP.group $ PP.string stars <> inner <> PP.string stars (toDocStrikethrough ppe -> Just d) -> - PP.group $ "~~" <> rec d <> "~~" + let inner = rec d + quotes = oneMore '~' inner + in PP.group $ PP.string quotes <> inner <> PP.string quotes (toDocGroup ppe -> Just d) -> PP.group $ rec d (toDocColumn ppe -> Just ds) -> diff --git a/parser-typechecker/src/Unison/TypeParser.hs b/parser-typechecker/src/Unison/TypeParser.hs index 4a37790b1b..7fc5e23929 100644 --- a/parser-typechecker/src/Unison/TypeParser.hs +++ b/parser-typechecker/src/Unison/TypeParser.hs @@ -7,6 +7,7 @@ import Unison.Prelude import qualified Text.Megaparsec as P import qualified Unison.Lexer as L import Unison.Parser +import Unison.Parser.Ann (Ann(..)) import Unison.Type (Type) import qualified Unison.Type as Type import Unison.Var (Var) @@ -71,7 +72,7 @@ type2 = do effect :: Var v => TypeP v effect = do es <- effectList - t <- valueTypeLeaf + t <- type2 pure (Type.effect1 (ann es <> ann t) es t) effectList :: Var v => TypeP v @@ -83,9 +84,9 @@ effectList = do sequenceTyp :: Var v => TypeP v sequenceTyp = do - open <- reserved "[" + open <- openBlockWith "[" t <- valueType - close <- reserved "]" + close <- closeBlock let a = ann open <> ann close pure $ Type.app a (Type.list a) t diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index 12677efa4c..c4a9af53d7 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -9,19 +9,21 @@ import qualified Data.Map as Map import Unison.HashQualified (HashQualified) import Unison.Name ( Name ) import Unison.NamePrinter (styleHashQualified'') -import Unison.PrettyPrintEnv (PrettyPrintEnv, Imports, elideFQN) +import Unison.PrettyPrintEnv (PrettyPrintEnv) import qualified Unison.PrettyPrintEnv as PrettyPrintEnv -import Unison.Reference (pattern Builtin) +import Unison.PrettyPrintEnv.FQN (Imports, elideFQN) +import Unison.Reference (Reference, pattern Builtin) import Unison.Type import Unison.Util.Pretty (ColorText, Pretty, Width) import Unison.Util.ColorText (toPlain) import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText (SyntaxText) import qualified Unison.Util.Pretty as PP import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Builtin.Decls as DD +type SyntaxText = S.SyntaxText' Reference + pretty :: forall v a . (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText pretty ppe = PP.syntaxToColor . prettySyntax ppe @@ -102,40 +104,42 @@ prettyRaw n im p tp = go n im p tp in (fmt S.TypeOperator "βˆ€ " <> vformatted <> fmt S.TypeOperator ".") `PP.hang` go n im (-1) body t@(Arrow' _ _) -> case t of - EffectfulArrows' (Ref' DD.UnitRef) rest -> arrows True True rest + EffectfulArrows' (Ref' DD.UnitRef) rest -> + PP.parenthesizeIf (p >= 10) $ arrows True True rest EffectfulArrows' fst rest -> case fst of - Var' v | Var.name v == "()" - -> fmt S.DelayForceChar "'" <> arrows False True rest + Var' v | Var.name v == "()" -> + PP.parenthesizeIf (p >= 10) $ arrows True True rest _ -> PP.parenthesizeIf (p >= 0) $ go n im 0 fst <> arrows False False rest _ -> "error" _ -> "error" effects Nothing = mempty - effects (Just es) = PP.group $ (fmt S.AbilityBraces "{") <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}") + effects (Just es) = PP.group $ fmt S.AbilityBraces "{" <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}") + -- `first`: is this the first argument? + -- `mes`: list of effects arrow delay first mes = - (if first then mempty else PP.softbreak <> (fmt S.TypeOperator "->")) - <> (if delay then (if first then (fmt S.DelayForceChar "'") else (fmt S.DelayForceChar " '")) else mempty) + (if first then mempty else PP.softbreak <> fmt S.TypeOperator "->") + <> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty) <> effects mes - <> if (isJust mes) || (not delay) && (not first) then " " else mempty + <> if isJust mes || not delay && not first then " " else mempty - arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> (fmt S.Unit "()") + arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> fmt S.Unit "()" arrows delay first ((mes, Ref' DD.UnitRef) : rest) = - arrow delay first mes <> (parenNoGroup delay $ arrows True True rest) + arrow delay first mes <> parenNoGroup delay (arrows True True rest) arrows delay first ((mes, arg) : rest) = - arrow delay first mes - <> ( parenNoGroup (delay && (not $ null rest)) - $ go n im 0 arg - <> arrows False False rest - ) + arrow delay first mes <> parenNoGroup + (delay && not (null rest)) + (go n im 0 arg <> arrows False False rest) + arrows False False [] = mempty arrows False True [] = mempty -- not reachable arrows True _ [] = mempty -- not reachable - paren True s = PP.group $ ( fmt S.Parenthesis "(" ) <> s <> ( fmt S.Parenthesis ")" ) + paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" paren False s = PP.group s - parenNoGroup True s = ( fmt S.Parenthesis "(" ) <> s <> ( fmt S.Parenthesis ")" ) + parenNoGroup True s = fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" parenNoGroup False s = s fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 2313c5b8b6..15db6377ca 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -57,7 +57,6 @@ import Data.Functor.Compose ( Compose(..) ) import Data.List import Data.List.NonEmpty ( NonEmpty ) import qualified Data.Map as Map -import Data.Ord ( comparing ) import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty ( NESeq ) import qualified Data.Sequence.NonEmpty as NESeq @@ -1157,7 +1156,8 @@ checkCases scrutType outType cases@(Term.MatchCase _ _ t : _) vt = existentialp lo v appendContext [existential v] subtype (Type.effectV lo (lo, Type.effects lo es) (lo, vt)) sty - coalesceWanteds =<< traverse (checkCase scrutType outType) cases + scrutType' <- ungeneralize scrutType + coalesceWanteds =<< traverse (checkCase scrutType' outType) cases getEffect :: Var v => Ord loc => Reference -> Int -> M v loc (Type v loc) @@ -1221,8 +1221,8 @@ checkPattern -> Pattern loc -> StateT [v] (M v loc) [(v, v)] checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern"::String, tx, ty) False = undefined -checkPattern scrutineeType0 p = - lift (ungeneralize scrutineeType0) >>= \scrutineeType -> case p of +checkPattern scrutineeType p = + case p of Pattern.Unbound _ -> pure [] Pattern.Var _loc -> do v <- getAdvance p @@ -2109,11 +2109,16 @@ refineEffectVar -> [Type v loc] -> B.Blank loc -> v + -> Type v loc -> M v loc () -refineEffectVar _ es _ v +refineEffectVar _ es _ v _ | debugShow ("refineEffectVar", es, v) = undefined -refineEffectVar _ [] _ _ = pure () -refineEffectVar l es blank v = do +refineEffectVar _ [] _ _ _ = pure () +refineEffectVar l es blank v tv + | ev <- TypeVar.Existential blank v + , any (\e -> ev `Set.member` Type.freeVars e) es + = getContext >>= failWith . AbilityCheckFailure [tv] es + | otherwise = do slack <- freshenVar Var.inferAbility evs <- traverse (\e -> freshenVar (nameFrom Var.inferAbility e)) es let locs = loc <$> es @@ -2220,6 +2225,37 @@ expandWanted . (traverse.traverse) applyM +pruneConcrete + :: Var v + => Ord loc + => (Maybe (Term v loc) -> Type v loc -> M v loc ()) + -> Wanted v loc + -> Wanted v loc + -> [Type v loc] + -> M v loc (Wanted v loc) +pruneConcrete _ acc [] _ = pure (reverse acc) +pruneConcrete missing acc ((loc, w):ws) have + | Just v <- find (headMatch w) have = do + subtype v w `orElse` missing loc w + ws <- expandWanted ws + have <- expandAbilities have + pruneConcrete missing acc ws have + | otherwise = pruneConcrete missing ((loc,w):acc) ws have + +pruneVariables + :: Var v + => Ord loc + => Wanted v loc + -> Wanted v loc + -> M v loc (Wanted v loc) +pruneVariables acc [] = pure $ reverse acc +pruneVariables acc ((loc,v):vs) = do + discard <- defaultAbility v + vs <- expandWanted vs + if discard + then pruneVariables acc vs + else pruneVariables ((loc,v):acc) vs + pruneAbilities :: Var v => Ord loc @@ -2228,12 +2264,18 @@ pruneAbilities -> M v loc (Wanted v loc) pruneAbilities want0 have0 | debugShow ("pruneAbilities", want0, have0) = undefined -pruneAbilities want0 have0 - = go [] (sortBy (comparing (isVar.snd)) want0) have0 +pruneAbilities want0 have0 = do + pwant <- pruneConcrete missing [] want0 have0 + if pwant /= want0 + then do + want <- expandWanted pwant + have <- expandAbilities have0 + pruneAbilities want have + else -- fixed point + if dflt + then expandWanted =<< pruneVariables [] pwant + else pure pwant where - isVar (Type.Var' _) = True - isVar _ = False - isExistential (Type.Var' TypeVar.Existential{}) = True isExistential _ = False @@ -2246,22 +2288,6 @@ pruneAbilities want0 have0 dflt = not $ any isExistential have0 - go acc [] _ = pure acc - go acc ((loc, w):want) have - | Just v <- find (headMatch w) have = do - subtype v w `orElse` missing loc w - want <- expandWanted want - have <- expandAbilities have - go acc want have - | dflt = do - discard <- defaultAbility w - want <- expandWanted want - have <- expandAbilities have - if discard - then go acc want have - else go ((loc, w):acc) want have - | otherwise = go ((loc, w):acc) want have - subAbilities :: Var v => Ord loc @@ -2277,11 +2303,11 @@ subAbilities want have = do have <- expandAbilities have case (want , mapMaybe ex have) of ([], _) -> pure () - (want@((_, w):_), [(b, ve)]) -> - refineEffectVar (loc w) (snd <$> want) b ve -- `orElse` die src w + (want@((_, w):_), [(b, ve, tv)]) -> + refineEffectVar (loc w) (snd <$> want) b ve tv -- `orElse` die src w ((src, w):_, _) -> die src w where - ex (Type.Var' (TypeVar.Existential b v)) = Just (b, v) + ex t@(Type.Var' (TypeVar.Existential b v)) = Just (b, v, t) ex _ = Nothing die src w = maybe id (scope . InSynthesize) src do ctx <- getContext diff --git a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs index 2925e7c005..161bf50b46 100644 --- a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs +++ b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs @@ -3,7 +3,7 @@ module Unison.Typechecker.TypeLookup where import Unison.Prelude import Unison.Reference (Reference) -import Unison.Referent (Referent) +import Unison.Referent (Referent, ConstructorId) import Unison.Type (Type) import qualified Data.Map as Map import qualified Unison.ConstructorType as CT @@ -35,11 +35,11 @@ constructorType tl r = (const CT.Data <$> Map.lookup r (dataDecls tl)) <|> (const CT.Effect <$> Map.lookup r (effectDecls tl)) -typeOfDataConstructor :: TypeLookup v a -> Reference -> Int -> Maybe (Type v a) +typeOfDataConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a) typeOfDataConstructor tl r cid = go =<< Map.lookup r (dataDecls tl) where go dd = DD.typeOfConstructor dd cid -typeOfEffectConstructor :: TypeLookup v a -> Reference -> Int -> Maybe (Type v a) +typeOfEffectConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a) typeOfEffectConstructor tl r cid = go =<< Map.lookup r (effectDecls tl) where go dd = DD.typeOfConstructor (DD.toDataDecl dd) cid diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index ff23c3fd51..9f03a64144 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -3,55 +3,60 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -module Unison.UnisonFile where - +module Unison.UnisonFile + ( -- * UnisonFile + UnisonFile (..), + pattern UnisonFile, + allWatches, + dataDeclarations, + declsToTypeLookup, + dependencies, + effectDeclarations, + typecheckingTerm, + watchesOfKind, + + -- * TypecheckedUnisonFile + TypecheckedUnisonFile (..), + allTerms, + dataDeclarations', + discardTypes, + effectDeclarations', + hashConstructors, + hashTerms, + indexByReference, + lookupDecl, + nonEmpty, + termSignatureExternalLabeledDependencies, + topLevelComponents, + typecheckedUnisonFile, + ) +where import Unison.Prelude import Control.Lens -import Data.Bifunctor (second, first) -import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Unison.ABT as ABT +import qualified Unison.Builtin.Decls as DD import qualified Unison.ConstructorType as CT -import Unison.DataDeclaration (DataDeclaration) -import Unison.DataDeclaration (EffectDeclaration(..)) -import Unison.DataDeclaration (hashDecls) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import qualified Unison.DataDeclaration as DD -import qualified Unison.Builtin.Decls as DD -import qualified Unison.Name as Name -import qualified Unison.Names3 as Names -import Unison.Reference (Reference) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import Unison.Term (Term) -import qualified Unison.Term as Term -import Unison.Type (Type) -import qualified Unison.Type as Type -import qualified Unison.Util.List as List -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as Relation -import Unison.Var (Var) -import qualified Unison.Var as Var -import qualified Unison.Typechecker.TypeLookup as TL -import Unison.Names3 (Names0) -import qualified Unison.LabeledDependency as LD +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.LabeledDependency (LabeledDependency) --- import qualified Unison.Typechecker.Components as Components - -data UnisonFile v a = UnisonFileId { - dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), - effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), - terms :: [(v, Term v a)], - watches :: Map WatchKind [(v, Term v a)] -} deriving Show - -pattern UnisonFile ds es tms ws <- - UnisonFileId (fmap (first Reference.DerivedId) -> ds) - (fmap (first Reference.DerivedId) -> es) - tms - ws -{-# COMPLETE UnisonFile #-} - +import qualified Unison.LabeledDependency as LD +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.Typechecker.TypeLookup as TL +import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), pattern TypecheckedUnisonFile, pattern UnisonFile) +import qualified Unison.Util.List as List +import Unison.Var (Var) +import Unison.WatchKind (WatchKind, pattern TestWatch) dataDeclarations :: UnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId @@ -68,10 +73,6 @@ watchesOfOtherKinds kind uf = allWatches :: UnisonFile v a -> [(v, Term v a)] allWatches = join . Map.elems . watches -type WatchKind = Var.WatchKind -pattern RegularWatch = Var.RegularWatch -pattern TestWatch = Var.TestWatch - -- Converts a file to a single let rec with a body of `()`, for -- purposes of typechecking. typecheckingTerm :: (Var v, Monoid a) => UnisonFile v a -> Term v a @@ -83,60 +84,40 @@ typecheckingTerm uf = f w = let wa = ABT.annotation w in Term.ann wa w (DD.testResultType wa) testWatches = map (second f) $ watchesOfKind TestWatch uf --- Converts a file and a body to a single let rec with the given body. -uberTerm' :: (Var v, Monoid a) => UnisonFile v a -> Term v a -> Term v a -uberTerm' uf body = - Term.letRec' True (terms uf <> allWatches uf) $ body - --- A UnisonFile after typechecking. Terms are split into groups by --- cycle and the type of each term is known. -data TypecheckedUnisonFile v a = - TypecheckedUnisonFileId { - dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), - effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), - topLevelComponents' :: [[(v, Term v a, Type v a)]], - watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], - hashTermsId :: Map v (Reference.Id, Term v a, Type v a) - } deriving Show - -- backwards compatibility with the old data type dataDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations' = fmap (first Reference.DerivedId) . dataDeclarationsId' effectDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, EffectDeclaration v a) effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId' -hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Term v a, Type v a) +hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Maybe WatchKind, Term v a, Type v a) hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId -{-# COMPLETE TypecheckedUnisonFile #-} -pattern TypecheckedUnisonFile ds es tlcs wcs hts <- - TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) - (fmap (first Reference.DerivedId) -> es) - tlcs - wcs - (fmap (over _1 Reference.DerivedId) -> hts) - --- todo: this is confusing, right? --- currently: create a degenerate TypecheckedUnisonFile --- multiple definitions of "top-level components" non-watch vs w/ watch -typecheckedUnisonFile :: Var v +typecheckedUnisonFile :: forall v a. Var v => Map v (Reference.Id, DataDeclaration v a) -> Map v (Reference.Id, EffectDeclaration v a) -> [[(v, Term v a, Type v a)]] -> [(WatchKind, [(v, Term v a, Type v a)])] -> TypecheckedUnisonFile v a typecheckedUnisonFile datas effects tlcs watches = - file0 { hashTermsId = hashImpl file0 } + TypecheckedUnisonFileId datas effects tlcs watches hashImpl where - file0 = TypecheckedUnisonFileId datas effects tlcs watches mempty - hashImpl file = let - -- test watches are added to the codebase also - -- todo: maybe other kinds of watches too - components = topLevelComponents file - types = Map.fromList [(v,t) | (v,_,t) <- join components ] - terms0 = Map.fromList [(v,e) | (v,e,_) <- join components ] - hcs = Term.hashComponents terms0 - in Map.fromList [ (v, (r, e, t)) | (v, (r, e)) <- Map.toList hcs, - Just t <- [Map.lookup v types] ] + hashImpl = let + -- |includes watches + allTerms :: [(v, Term v a, Type v a)] + allTerms = join tlcs ++ join (snd <$> watches) + types :: Map v (Type v a) + types = Map.fromList [(v,t) | (v,_,t) <- allTerms ] + watchKinds :: Map v (Maybe WatchKind) + watchKinds = Map.fromList $ + [(v,Nothing) | (v,_e,_t) <- join tlcs] + ++ [(v, Just wk) | (wk, wkTerms) <- watches, (v, _e, _t) <- wkTerms ] + -- good spot incorporate type of term into its hash, if not already present as an annotation (#2276) + hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, e, _t) -> (v, e)) <$> allTerms + in Map.fromList + [ (v, (r, wk, e, t)) + | (v, (r, e)) <- Map.toList hcs + , Just t <- [Map.lookup v types] + , wk <- [Map.findWithDefault (error $ show v ++ " missing from watchKinds") v watchKinds]] lookupDecl :: Ord v => v -> TypecheckedUnisonFile v a -> Maybe (Reference.Id, DD.Decl v a) @@ -151,22 +132,18 @@ indexByReference uf = (tms, tys) tys = Map.fromList (over _2 Right <$> toList (dataDeclarationsId' uf)) <> Map.fromList (over _2 Left <$> toList (effectDeclarationsId' uf)) tms = Map.fromList [ - (r, (tm,ty)) | (Reference.DerivedId r, tm, ty) <- toList (hashTerms uf) ] + (r, (tm,ty)) | (Reference.DerivedId r, _wk, tm, ty) <- toList (hashTerms uf) ] allTerms :: Ord v => TypecheckedUnisonFile v a -> Map v (Term v a) allTerms uf = Map.fromList [ (v, t) | (v, t, _) <- join $ topLevelComponents' uf ] +-- |the top level components (no watches) plus test watches. topLevelComponents :: TypecheckedUnisonFile v a -> [[(v, Term v a, Type v a)]] topLevelComponents file = topLevelComponents' file ++ [ comp | (TestWatch, comp) <- watchComponents file ] -getDecl' :: Ord v => TypecheckedUnisonFile v a -> v -> Maybe (DD.Decl v a) -getDecl' uf v = - (Right . snd <$> Map.lookup v (dataDeclarations' uf)) <|> - (Left . snd <$> Map.lookup v (effectDeclarations' uf)) - -- External type references that appear in the types of the file's terms termSignatureExternalLabeledDependencies :: Ord v => TypecheckedUnisonFile v a -> Set LabeledDependency @@ -175,7 +152,7 @@ termSignatureExternalLabeledDependencies Set.difference (Set.map LD.typeRef . foldMap Type.dependencies - . fmap (\(_r, _e, t) -> t) + . fmap (\(_r, _wk, _e, t) -> t) . toList $ hashTerms) -- exclude any references that are defined in this file @@ -183,32 +160,6 @@ termSignatureExternalLabeledDependencies (map (LD.typeRef . fst) . toList) dataDeclarations' <> (map (LD.typeRef . fst) . toList) effectDeclarations') --- Returns a relation for the dependencies of this file. The domain is --- the dependent, and the range is its dependencies, thus: --- `R.lookupDom r (dependencies file)` returns the set of dependencies --- of the reference `r`. -dependencies' :: - forall v a. Var v => TypecheckedUnisonFile v a -> Relation Reference.Id Reference -dependencies' file = let - terms :: Map v (Reference.Id, Term v a, Type v a) - terms = hashTermsId file - decls :: Map v (Reference.Id, DataDeclaration v a) - decls = dataDeclarationsId' file <> - fmap (second toDataDecl) (effectDeclarationsId' file ) - termDeps = foldl' f Relation.empty $ toList terms - allDeps = foldl' g termDeps $ toList decls - f acc (r, tm, tp) = acc <> termDeps <> typeDeps - where termDeps = - Relation.fromList [ (r, dep) | dep <- toList (Term.dependencies tm)] - typeDeps = - Relation.fromList [ (r, dep) | dep <- toList (Type.dependencies tp)] - g acc (r, decl) = acc <> ctorDeps - where ctorDeps = - Relation.fromList [ (r, dep) | (_, _, tp) <- DD.constructors' decl - , dep <- toList (Type.dependencies tp) - ] - in allDeps - -- Returns the dependencies of the `UnisonFile` input. Needed so we can -- load information about these dependencies before starting typechecking. dependencies :: (Monoid a, Var v) => UnisonFile v a -> Set Reference @@ -230,30 +181,6 @@ declsToTypeLookup uf = TL.TypeLookup mempty (wrangle (effectDeclarations uf)) where wrangle = Map.fromList . Map.elems -toNames :: Var v => UnisonFile v a -> Names0 -toNames uf = datas <> effects - where - datas = foldMap DD.dataDeclToNames' (Map.toList (dataDeclarationsId uf)) - effects = foldMap DD.effectDeclToNames' (Map.toList (effectDeclarationsId uf)) - -typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 -typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where - terms = Relation.fromList - [ (Name.fromVar v, Referent.Ref r) - | (v, (r, _, _)) <- Map.toList $ hashTerms uf ] - types = Relation.fromList - [ (Name.fromVar v, r) - | (v, r) <- Map.toList $ fmap fst (dataDeclarations' uf) - <> fmap fst (effectDeclarations' uf) ] - ctors = Relation.fromMap - . Map.mapKeys Name.fromVar - . fmap (fmap Reference.DerivedId) - . hashConstructors - $ uf - -typecheckedUnisonFile0 :: Ord v => TypecheckedUnisonFile v a -typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty - -- Returns true if the file has any definitions or watches nonEmpty :: TypecheckedUnisonFile v a -> Bool nonEmpty uf = @@ -266,113 +193,7 @@ hashConstructors :: forall v a. Ord v => TypecheckedUnisonFile v a -> Map v Referent.Id hashConstructors file = let ctors1 = Map.elems (dataDeclarationsId' file) >>= \(ref, dd) -> - [ (v, Referent.Con' ref i CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ] + [ (v, Referent.ConId ref i CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ] ctors2 = Map.elems (effectDeclarationsId' file) >>= \(ref, dd) -> - [ (v, Referent.Con' ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] + [ (v, Referent.ConId ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] in Map.fromList (ctors1 ++ ctors2) - -type CtorLookup = Map String (Reference, Int) - --- Substitutes free type and term variables occurring in the terms of this --- `UnisonFile` using `externalNames`. --- --- Hash-qualified names are substituted during parsing, but non-HQ names are --- substituted at the end of parsing, since they can be locally bound. Example, in --- `x -> x + math.sqrt 2`, we don't know if `math.sqrt` is locally bound until --- we are done parsing, whereas `math.sqrt#abc` can be resolved immediately --- as it can't refer to a local definition. -bindNames :: Var v - => Names0 - -> UnisonFile v a - -> Names.ResolutionResult v a (UnisonFile v a) -bindNames names (UnisonFileId d e ts ws) = do - -- todo: consider having some kind of binding structure for terms & watches - -- so that you don't weirdly have free vars to tiptoe around. - -- The free vars should just be the things that need to be bound externally. - let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst) - termVarsSet = Set.fromList termVars - -- todo: can we clean up this lambda using something like `second` - ts' <- traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t) ts - ws' <- traverse (traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t)) ws - pure $ UnisonFileId d e ts' ws' - -constructorType :: - Var v => UnisonFile v a -> Reference -> Maybe CT.ConstructorType -constructorType = TL.constructorType . declsToTypeLookup - -data Env v a = Env - -- Data declaration name to hash and its fully resolved form - { datasId :: Map v (Reference.Id, DataDeclaration v a) - -- Effect declaration name to hash and its fully resolved form - , effectsId :: Map v (Reference.Id, EffectDeclaration v a) - -- Naming environment - , names :: Names0 -} - -datas :: Env v a -> Map v (Reference, DataDeclaration v a) -datas = fmap (first Reference.DerivedId) . datasId - -effects :: Env v a -> Map v (Reference, EffectDeclaration v a) -effects = fmap (first Reference.DerivedId) . effectsId - -data Error v a - -- A free type variable that couldn't be resolved - = UnknownType v a - -- A variable which is both a data and an ability declaration - | DupDataAndAbility v a a - deriving (Eq,Ord,Show) - --- This function computes hashes for data and effect declarations, and --- also returns a function for resolving strings to (Reference, ConstructorId) --- for parsing of pattern matching --- --- If there are duplicate declarations, the duplicated names are returned on the --- left. -environmentFor - :: forall v a . Var v - => Names0 - -> Map v (DataDeclaration v a) - -> Map v (EffectDeclaration v a) - -> Names.ResolutionResult v a (Either [Error v a] (Env v a)) -environmentFor names dataDecls0 effectDecls0 = do - let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0 - -- data decls and hash decls may reference each other, and thus must be hashed together - dataDecls :: Map v (DataDeclaration v a) <- - traverse (DD.bindNames locallyBoundTypes names) dataDecls0 - effectDecls :: Map v (EffectDeclaration v a) <- - traverse (DD.withEffectDeclM (DD.bindNames locallyBoundTypes names)) effectDecls0 - let allDecls0 :: Map v (DataDeclaration v a) - allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) - hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- - hashDecls allDecls0 - -- then we have to pick out the dataDecls from the effectDecls - let - allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ] - dataDecls' = Map.difference allDecls effectDecls - effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls - -- ctor and effect terms - ctors = foldMap DD.dataDeclToNames' (Map.toList dataDecls') - effects = foldMap DD.effectDeclToNames' (Map.toList effectDecls') - names' = ctors <> effects - overlaps = let - w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed) - in Map.elems $ Map.intersectionWithKey w dataDecls effectDecls where - okVars = Map.keysSet allDecls0 - unknownTypeRefs = Map.elems allDecls0 >>= \dd -> - let cts = DD.constructorTypes dd - in cts >>= \ct -> [ UnknownType v a | (v,a) <- ABT.freeVarOccurrences mempty ct - , not (Set.member v okVars) ] - pure $ - if null overlaps && null unknownTypeRefs - then pure $ Env dataDecls' effectDecls' names' - else Left (unknownTypeRefs ++ overlaps) - -allVars :: Ord v => UnisonFile v a -> Set v -allVars (UnisonFile ds es ts ws) = Set.unions - [ Map.keysSet ds - , foldMap (DD.allVars . snd) ds - , Map.keysSet es - , foldMap (DD.allVars . toDataDecl . snd) es - , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- ts ] - , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- join . Map.elems $ ws ] - ] diff --git a/parser-typechecker/src/Unison/UnisonFile/Env.hs b/parser-typechecker/src/Unison/UnisonFile/Env.hs new file mode 100644 index 0000000000..d73bae5fe2 --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Env.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Env (Env(..), datas) where + +import Unison.Prelude + +import Data.Bifunctor (first) +import Unison.DataDeclaration (DataDeclaration) +import Unison.DataDeclaration (EffectDeclaration(..)) +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Names3 (Names0) + +data Env v a = Env + -- Data declaration name to hash and its fully resolved form + { datasId :: Map v (Reference.Id, DataDeclaration v a) + -- Effect declaration name to hash and its fully resolved form + , effectsId :: Map v (Reference.Id, EffectDeclaration v a) + -- Naming environment + , names :: Names0 +} + +datas :: Env v a -> Map v (Reference, DataDeclaration v a) +datas = fmap (first Reference.DerivedId) . datasId diff --git a/parser-typechecker/src/Unison/UnisonFile/Error.hs b/parser-typechecker/src/Unison/UnisonFile/Error.hs new file mode 100644 index 0000000000..9c391ada2e --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Error.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Error where + +data Error v a + -- A free type variable that couldn't be resolved + = UnknownType v a + -- A variable which is both a data and an ability declaration + | DupDataAndAbility v a a + deriving (Eq,Ord,Show) + diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs new file mode 100644 index 0000000000..ef62ce8888 --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Names where + +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) +import qualified Unison.DataDeclaration as DD +import qualified Unison.DataDeclaration.Names as DD.Names +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Names3 (Names0) +import qualified Unison.Names3 as Names +import Unison.Prelude +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import qualified Unison.Term as Term +import qualified Unison.UnisonFile as UF +import Unison.UnisonFile.Env (Env (..)) +import Unison.UnisonFile.Error (Error (DupDataAndAbility, UnknownType)) +import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) +import qualified Unison.Util.Relation as Relation +import Unison.Var (Var) +import qualified Unison.WatchKind as WK + +toNames :: Var v => UnisonFile v a -> Names0 +toNames uf = datas <> effects + where + datas = foldMap DD.Names.dataDeclToNames' (Map.toList (UF.dataDeclarationsId uf)) + effects = foldMap DD.Names.effectDeclToNames' (Map.toList (UF.effectDeclarationsId uf)) + +typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 +typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where + terms = Relation.fromList + [ (Name.fromVar v, Referent.Ref r) + | (v, (r, wk, _, _)) <- Map.toList $ UF.hashTerms uf, wk == Nothing || wk == Just WK.TestWatch ] + types = Relation.fromList + [ (Name.fromVar v, r) + | (v, r) <- Map.toList $ fmap fst (UF.dataDeclarations' uf) + <> fmap fst (UF.effectDeclarations' uf) ] + ctors = Relation.fromMap + . Map.mapKeys Name.fromVar + . fmap (fmap Reference.DerivedId) + . UF.hashConstructors + $ uf + +typecheckedUnisonFile0 :: Ord v => TypecheckedUnisonFile v a +typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty + + +-- Substitutes free type and term variables occurring in the terms of this +-- `UnisonFile` using `externalNames`. +-- +-- Hash-qualified names are substituted during parsing, but non-HQ names are +-- substituted at the end of parsing, since they can be locally bound. Example, in +-- `x -> x + math.sqrt 2`, we don't know if `math.sqrt` is locally bound until +-- we are done parsing, whereas `math.sqrt#abc` can be resolved immediately +-- as it can't refer to a local definition. +bindNames :: Var v + => Names0 + -> UnisonFile v a + -> Names.ResolutionResult v a (UnisonFile v a) +bindNames names (UnisonFileId d e ts ws) = do + -- todo: consider having some kind of binding structure for terms & watches + -- so that you don't weirdly have free vars to tiptoe around. + -- The free vars should just be the things that need to be bound externally. + let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst) + termVarsSet = Set.fromList termVars + -- todo: can we clean up this lambda using something like `second` + ts' <- traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t) ts + ws' <- traverse (traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t)) ws + pure $ UnisonFileId d e ts' ws' + +-- This function computes hashes for data and effect declarations, and +-- also returns a function for resolving strings to (Reference, ConstructorId) +-- for parsing of pattern matching +-- +-- If there are duplicate declarations, the duplicated names are returned on the +-- left. +environmentFor + :: forall v a . Var v + => Names0 + -> Map v (DataDeclaration v a) + -> Map v (EffectDeclaration v a) + -> Names.ResolutionResult v a (Either [Error v a] (Env v a)) +environmentFor names dataDecls0 effectDecls0 = do + let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0 + -- data decls and hash decls may reference each other, and thus must be hashed together + dataDecls :: Map v (DataDeclaration v a) <- + traverse (DD.Names.bindNames locallyBoundTypes names) dataDecls0 + effectDecls :: Map v (EffectDeclaration v a) <- + traverse (DD.withEffectDeclM (DD.Names.bindNames locallyBoundTypes names)) effectDecls0 + let allDecls0 :: Map v (DataDeclaration v a) + allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) + hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDecls allDecls0 + -- then we have to pick out the dataDecls from the effectDecls + let + allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ] + dataDecls' = Map.difference allDecls effectDecls + effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls + -- ctor and effect terms + ctors = foldMap DD.Names.dataDeclToNames' (Map.toList dataDecls') + effects = foldMap DD.Names.effectDeclToNames' (Map.toList effectDecls') + names' = ctors <> effects + overlaps = let + w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed) + in Map.elems $ Map.intersectionWithKey w dataDecls effectDecls where + okVars = Map.keysSet allDecls0 + unknownTypeRefs = Map.elems allDecls0 >>= \dd -> + let cts = DD.constructorTypes dd + in cts >>= \ct -> [ UnknownType v a | (v,a) <- ABT.freeVarOccurrences mempty ct + , not (Set.member v okVars) ] + pure $ + if null overlaps && null unknownTypeRefs + then pure $ Env dataDecls' effectDecls' names' + else Left (unknownTypeRefs ++ overlaps) diff --git a/parser-typechecker/src/Unison/UnisonFile/Type.hs b/parser-typechecker/src/Unison/UnisonFile/Type.hs new file mode 100644 index 0000000000..f48a4688ac --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Type.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Type where + +import Unison.Prelude + +import Control.Lens +import Data.Bifunctor (first) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) +import qualified Unison.Reference as Reference +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import Unison.WatchKind (WatchKind) + +data UnisonFile v a = UnisonFileId { + dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), + effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), + terms :: [(v, Term v a)], + watches :: Map WatchKind [(v, Term v a)] +} deriving Show + +pattern UnisonFile ds es tms ws <- + UnisonFileId (fmap (first Reference.DerivedId) -> ds) + (fmap (first Reference.DerivedId) -> es) + tms + ws +{-# COMPLETE UnisonFile #-} + +-- |A UnisonFile after typechecking. Terms are split into groups by +-- cycle and the type of each term is known. +data TypecheckedUnisonFile v a = + TypecheckedUnisonFileId { + dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), + effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), + topLevelComponents' :: [[(v, Term v a, Type v a)]], + watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], + hashTermsId :: Map v (Reference.Id, Maybe WatchKind, Term v a, Type v a) + } deriving Show + +{-# COMPLETE TypecheckedUnisonFile #-} +pattern TypecheckedUnisonFile ds es tlcs wcs hts <- + TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) + (fmap (first Reference.DerivedId) -> es) + tlcs + wcs + (fmap (over _1 Reference.DerivedId) -> hts) + +instance Ord v => Functor (TypecheckedUnisonFile v) where + fmap f (TypecheckedUnisonFileId ds es tlcs wcs hashTerms) = + TypecheckedUnisonFileId ds' es' tlcs' wcs' hashTerms' + where + ds' = fmap (\(id, dd) -> (id, fmap f dd)) ds + es' = fmap (\(id, ed) -> (id, fmap f ed)) es + tlcs' = (fmap.fmap) (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tlcs + wcs' = map (\(wk, tms) -> (wk, map (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tms)) wcs + hashTerms' = fmap (\(id, wk, tm, tp) -> (id, wk, Term.amap f tm, fmap f tp)) hashTerms diff --git a/parser-typechecker/src/Unison/Util/AnnotatedText.hs b/parser-typechecker/src/Unison/Util/AnnotatedText.hs index f80ba6d01b..4f53462fe7 100644 --- a/parser-typechecker/src/Unison/Util/AnnotatedText.hs +++ b/parser-typechecker/src/Unison/Util/AnnotatedText.hs @@ -14,7 +14,7 @@ import qualified Data.Foldable as Foldable import qualified Data.Map as Map import Data.Sequence (Seq ((:|>), (:<|))) import qualified Data.Sequence as Seq -import Unison.Lexer (Line, Pos (..)) +import Unison.Lexer.Pos (Line, Pos (..)) import Unison.Util.Monoid (intercalateMap) import Unison.Util.Range (Range (..), inRange) import qualified Data.ListLike as LL diff --git a/parser-typechecker/src/Unison/Util/Bytes.hs b/parser-typechecker/src/Unison/Util/Bytes.hs index 580c5586ed..c4c5a2a211 100644 --- a/parser-typechecker/src/Unison/Util/Bytes.hs +++ b/parser-typechecker/src/Unison/Util/Bytes.hs @@ -3,6 +3,7 @@ module Unison.Util.Bytes where +import Control.DeepSeq (NFData(..)) import Data.Bits (shiftR, shiftL, (.|.)) import Data.Char import Data.Memory.PtrMethods (memCompare, memEqual) @@ -17,6 +18,8 @@ import qualified Data.ByteArray as B import qualified Data.ByteArray.Encoding as BE import qualified Data.FingerTree as T import qualified Data.Text as Text +import qualified Codec.Compression.Zlib as Zlib +import qualified Codec.Compression.GZip as GZip -- Block is just `newtype Block a = Block ByteArray#` type ByteString = Block Word8 @@ -35,12 +38,27 @@ empty = Bytes mempty fromArray :: B.ByteArrayAccess ba => ba -> Bytes fromArray = snoc empty +zlibCompress :: Bytes -> Bytes +zlibCompress = fromLazyByteString . Zlib.compress . toLazyByteString + +gzipCompress :: Bytes -> Bytes +gzipCompress = fromLazyByteString . GZip.compress . toLazyByteString + +gzipDecompress :: Bytes -> Bytes +gzipDecompress = fromLazyByteString . GZip.decompress . toLazyByteString + +zlibDecompress :: Bytes -> Bytes +zlibDecompress = fromLazyByteString . Zlib.decompress . toLazyByteString + toArray :: forall bo . B.ByteArray bo => Bytes -> bo toArray b = B.concat (map B.convert (chunks b) :: [bo]) toLazyByteString :: Bytes -> LB.ByteString toLazyByteString b = LB.fromChunks $ map B.convert $ chunks b +fromLazyByteString :: LB.ByteString -> Bytes +fromLazyByteString b = fromChunks (map (view . B.convert) $ LB.toChunks b) + size :: Bytes -> Int size (Bytes bs) = getSum (T.measure bs) @@ -212,7 +230,7 @@ fillBE :: Word64 -> Int -> Ptr Word8 -> IO () fillBE n 0 p = poke p (fromIntegral n) >> return () fillBE n i p = poke p (fromIntegral (shiftR n (i * 8))) >> fillBE n (i - 1) (p `plusPtr` 1) - + encodeNat64be :: Word64 -> Bytes encodeNat64be n = Bytes (T.singleton (view (B.unsafeCreate 8 (fillBE n 7)))) @@ -361,3 +379,9 @@ instance B.ByteArrayAccess bytes => B.ByteArrayAccess (View bytes) where length = viewSize withByteArray v f = B.withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v)) + +instance NFData (View bs) where + rnf bs = seq bs () + +instance NFData Bytes where + rnf bs = rnf (chunks bs) diff --git a/parser-typechecker/src/Unison/Util/Convert.hs b/parser-typechecker/src/Unison/Util/Convert.hs new file mode 100644 index 0000000000..9bbba41472 --- /dev/null +++ b/parser-typechecker/src/Unison/Util/Convert.hs @@ -0,0 +1,10 @@ +module Unison.Util.Convert where + +class Convert a b where + convert :: a -> b + +class Parse a b where + parse :: a -> Maybe b + +instance (Parse a a2, Parse b b2) => Parse (a,b) (a2,b2) where + parse (a,b) = (,) <$> parse a <*> parse b diff --git a/parser-typechecker/src/Unison/Util/Menu.hs b/parser-typechecker/src/Unison/Util/Menu.hs deleted file mode 100644 index 90a49a907d..0000000000 --- a/parser-typechecker/src/Unison/Util/Menu.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} - -module Unison.Util.Menu (menu1, menuN, groupMenuN) where - -import Unison.Prelude - -import Data.List (find, isPrefixOf) -import qualified Data.Set as Set -import Data.Strings (strPadLeft) -import qualified Text.Read as Read -import Unison.Util.AnnotatedText (textEmpty) -import Unison.Util.ColorText (ColorText, toANSI) -import Unison.Util.Monoid (intercalateMap) --- utility - command line menus - -type Caption = ColorText -type Stylized = ColorText -type Keyword = String -type Console = IO String - -renderChoices :: forall a mc - . (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> (Keyword -> Bool) - -> Stylized -renderChoices render renderMeta groups metas isSelected = - showGroups <> showMetas - where - showGroups = intercalateMap "\n" format numberedGroups <> - if (not.null) groups && (not.null) metas then "\n\n" else "" - showMetas = intercalateMap "\n" (("["<>) . (<>"]") . renderMeta . snd) metas - numberedGroups :: [(([Keyword], [a]), Int)] - numberedGroups = zip groups [1..] - numberWidth = (1+) . floor @Double . logBase 10 . fromIntegral $ length groups - format :: (([Keyword], [a]), Int) -> Stylized - format ((keywords, as), number) = - intercalateMap - "\n" - (format1 number (length as) (any isSelected keywords)) - (zip as [0..]) - format1 :: Int -> Int -> Bool -> (a, Int) -> Stylized - format1 groupNumber groupSize isSelected (a, index) = - header <> bracket <> render a - where - header :: (Semigroup s, IsString s) => s - header = - (if representativeRow - then (if isSelected then "*" else " ") - <> fromString (strPadLeft ' ' numberWidth (show groupNumber)) - <> ". " - else fromString $ replicate (numberWidth + 3) ' ') - representativeRow :: Bool - representativeRow = index == (groupSize - 1) `div` 2 - bracket :: IsString s => s - bracket = - if maxGroupSize > 1 then - if groupSize == 1 then "β•Ά" - else if index == 0 then "β”Œ" - else if index < groupSize - 1 then "β”‚" - else "β””" - else "" - maxGroupSize = maximum (length . snd <$> groups) - - -{- - - - 1 ping - pong - 2 foo - 3 bar - - [cancel] - [help] - - >> ping - - -} - -menu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [(Keyword, a)] - -> [(Keyword, mc)] - -> Maybe Keyword - -> IO (Maybe (Either mc a)) -menu1 console caption render renderMeta groups metas initial = do - let groups' = [ ([k], [a]) | (k, a) <- groups ] - metas' = [ ([k], mc) | (k, mc) <- metas ] - groupMenu1 console caption render renderMeta groups' metas' initial >>= \case - Just (Right [a]) -> pure (Just (Right a)) - Just (Left mc) -> pure (Just (Left mc)) - Nothing -> pure Nothing - _ -> error "unpossible; by construction we should only get singleton lists back" - -_repeatMenu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Maybe Keyword - -> IO (Either mc [a]) -_repeatMenu1 console caption render renderMeta groups metas initial = - groupMenu1 console caption render renderMeta groups metas initial >>= \case - Just x -> pure x - Nothing -> _repeatMenu1 console caption render renderMeta groups metas initial - -groupMenu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Maybe Keyword - -> IO (Maybe (Either mc [a])) -groupMenu1 console caption render renderMeta groups metas initial = do - when ((not . textEmpty) caption) $ do - print . toANSI $ caption - putStrLn "" - print . toANSI $ renderChoices render renderMeta groups metas (`elem` initial) - resume - where - restart = groupMenu1 console caption render renderMeta groups metas initial - -- restart with an updated caption - restart' caption groups metas initial = - groupMenu1 console caption render renderMeta groups metas initial - resume = do - putStr "\n>> " - input <- console - case words input of - [] -> useExistingSelections groups initial - input : _ -> case Read.readMaybe input of - Just i -> pickGroupByNumber i - Nothing -> pickGroupByPrefix input - where - pickGroupByNumber :: Int -> IO (Maybe (Either mc [a])) - pickGroupByNumber i = case atMay groups (i-1) of - Nothing -> do - putStrLn $ "Please pick a number from 1 to " ++ - show (length groups) ++ "." - restart - Just (_keywords, as) -> pure (Just (Right as)) - pickGroupByPrefix :: String -> IO (Maybe (Either mc [a])) - pickGroupByPrefix s = case matchingItems groups metas s of - ([],[]) -> do - putStrLn $ "Sorry, '" ++ s ++ "' didn't match anything." - resume - ([(_, as)],[]) -> pure (Just (Right as)) - ([], [(_, mc)]) -> pure (Just (Left mc)) - (groups, metas) -> - restart' - "Please clarify your selection, or press Enter to back up:" - groups metas Nothing >>= \case - Nothing -> restart - x -> pure x - matchingItems :: - forall a mc. [([Keyword], [a])] -> [([Keyword], mc)] -> String - -> ([([Keyword], [a])], [([Keyword], mc)]) - matchingItems groups metas s = - (filter (any (s `isPrefixOf`) . fst) groups - ,filter (any (s `isPrefixOf`) . fst) metas) - useExistingSelections :: - [([Keyword], [a])] -> Maybe Keyword -> IO (Maybe (Either mc [a])) - useExistingSelections groups initial = case initial of - Nothing -> pure Nothing - Just initial -> - case findMatchingGroup [initial] groups of - Just group -> pure (Just (Right group)) - Nothing -> error $ - "Default selection \"" ++ show initial ++ "\"" ++ - " not found in choice groups:\n" ++ show (fst <$> groups) - findMatchingGroup :: forall a. [Keyword] -> [([Keyword], [a])] -> Maybe [a] - findMatchingGroup initials groups = - snd <$> find (\(keywords, _as) -> any (`elem` keywords) initials) groups - - -{- - - - 1 ping - pong - 2 foo - 3 bar - - [all] - [cancel] - [help] - - >> 1 3 - >> * - - -} -menuN :: Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> [Keyword] - -> IO (Either mc [[a]]) -menuN _console _caption _render _renderMeta _groups _metas _initials = pure (Right []) - -groupMenuN :: forall a mc. Ord a - => Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> [[Keyword]] - -> IO (Either mc [[a]]) -groupMenuN console caption render renderMeta groups metas initials = - groupMenuN' console caption render renderMeta groups metas (Set.fromList initials) - -groupMenuN' :: forall a mc. Ord a - => Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Set [Keyword] - -> IO (Either mc [[a]]) -groupMenuN' console caption render renderMeta groups metas initials = do - when ((not . textEmpty) caption) $ do - print . toANSI $ caption - putStrLn "" - print . toANSI $ renderChoices render renderMeta groups metas ((`any` initials) . elem) - resume initials - where - restart initials = groupMenuN' console caption render renderMeta groups metas initials - -- restart with an updated caption - restart' caption groups metas initials = - groupMenuN' console caption render renderMeta groups metas initials - resume :: Set [Keyword] -> IO (Either mc [[a]]) - resume initials = do - putStr "\n>> " - input <- console - case words input of - [] -> useExistingSelections groups initials - input : _ -> case Read.readMaybe input of - Just i -> pickGroupByNumber i - Nothing -> pickGroupByPrefix input - where - pickGroupByNumber :: Int -> IO (Either mc [[a]]) - pickGroupByNumber i = case atMay groups (i-1) of - Nothing -> do - putStrLn $ "Please pick a number from 1 to " ++ - show (length groups) ++ "." - restart initials - Just (kw, _) -> restart (Set.insert kw initials) - pickGroupByPrefix :: String -> IO (Either mc [[a]]) - pickGroupByPrefix s = case matchingItems groups metas s of - ([],[]) -> do - putStrLn $ "Sorry, '" ++ s ++ "' didn't match anything." - resume initials - ([], [(_, mc)]) -> pure (Left mc) - ([(kw, _)],[]) -> restart (Set.insert kw initials) - (_, _) -> - restart' - "Your prefix matched both groups and commands; please choose by number or use a longer prefix:" - groups metas initials - matchingItems :: - forall a mc. [([Keyword], [a])] -> [([Keyword], mc)] -> String - -> ([([Keyword], [a])], [([Keyword], mc)]) - matchingItems groups metas s = - (filter (any (s `isPrefixOf`) . fst) groups - ,filter (any (s `isPrefixOf`) . fst) metas) - useExistingSelections :: - [([Keyword], [a])] -> Set [Keyword] -> IO (Either mc [[a]]) - useExistingSelections groups initials = pure . pure $ - foldr go [] initials where - go kws selections = case findMatchingGroup kws groups of - Just as -> as : selections - Nothing -> selections - findMatchingGroup :: forall a. [Keyword] -> [([Keyword], [a])] -> Maybe [a] - findMatchingGroup initials groups = - snd <$> find (\(keywords, _as) -> any (`elem` keywords) initials) groups diff --git a/parser-typechecker/src/Unison/Util/Pretty.hs b/parser-typechecker/src/Unison/Util/Pretty.hs index e8f1efeed6..0e72d2ce31 100644 --- a/parser-typechecker/src/Unison/Util/Pretty.hs +++ b/parser-typechecker/src/Unison/Util/Pretty.hs @@ -269,7 +269,7 @@ toHTML cssPrefix avail p = CT.toHTML cssPrefix (render avail p) toPlainUnbroken :: Pretty ColorText -> String toPlainUnbroken p = CT.toPlain (renderUnbroken p) -syntaxToColor :: Pretty ST.SyntaxText -> Pretty ColorText +syntaxToColor :: Pretty (ST.SyntaxText' r) -> Pretty ColorText syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors -- set the syntax, overriding any present syntax diff --git a/parser-typechecker/src/Unison/Util/Range.hs b/parser-typechecker/src/Unison/Util/Range.hs index e2377bc027..93c76dea07 100644 --- a/parser-typechecker/src/Unison/Util/Range.hs +++ b/parser-typechecker/src/Unison/Util/Range.hs @@ -1,6 +1,6 @@ module Unison.Util.Range where -import Unison.Lexer (Pos(..)) +import Unison.Lexer.Pos (Pos(..)) -- | True if `_x` contains `_y` contains :: Range -> Range -> Bool diff --git a/parser-typechecker/src/Unison/Util/SyntaxText.hs b/parser-typechecker/src/Unison/Util/SyntaxText.hs index 2e1acc0b1b..e9a4b4f4ac 100644 --- a/parser-typechecker/src/Unison/Util/SyntaxText.hs +++ b/parser-typechecker/src/Unison/Util/SyntaxText.hs @@ -4,14 +4,12 @@ module Unison.Util.SyntaxText where import Unison.Prelude import Unison.Name (Name) -import Unison.Reference (Reference) -import Unison.Referent (Referent') +import Unison.Referent' (Referent') import Unison.HashQualified (HashQualified) import Unison.Pattern (SeqOp) import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate, segment) -type SyntaxText = SyntaxText' Reference type SyntaxText' r = AnnotatedText (Element r) -- The elements of the Unison grammar, for syntax highlighting purposes diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index 512e8760cb..0569323a64 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -10,9 +10,7 @@ import qualified Unison.Core.Test.Name as Name import qualified Unison.Test.ABT as ABT import qualified Unison.Test.Cache as Cache import qualified Unison.Test.ClearCache as ClearCache -import qualified Unison.Test.Codebase as Codebase import qualified Unison.Test.Codebase.Causal as Causal -import qualified Unison.Test.Codebase.FileCodebase as FileCodebase import qualified Unison.Test.Codebase.Path as Path import qualified Unison.Test.ColorText as ColorText import qualified Unison.Test.DataDeclaration as DataDeclaration @@ -39,7 +37,7 @@ import qualified Unison.Test.ANF as ANF import qualified Unison.Test.MCode as MCode import qualified Unison.Test.VersionParser as VersionParser import qualified Unison.Test.GitSync as GitSync -import qualified Unison.Test.Codebase.Upgrade12 as Upgrade12 +import qualified Unison.Test.CodebaseInit as CodebaseInit -- import qualified Unison.Test.BaseUpgradePushPullTest as BaseUpgradePushPullTest test :: Test () @@ -62,23 +60,20 @@ test = tests , Path.test , Causal.test , Referent.test - , FileCodebase.test , ABT.test , ANF.test , MCode.test , Var.test - , Codebase.test , ClearCache.test , Typechecker.test , UriParser.test , Context.test - , Upgrade12.test , GitSync.test - -- , BaseUpgradePushPullTest.test -- slowwwwww test involving upgrading base, hard-coded to arya's filesystem , Name.test , VersionParser.test , Pretty.test , PinBoard.test + , CodebaseInit.test ] main :: IO () diff --git a/parser-typechecker/tests/Unison/Test/ABT.hs b/parser-typechecker/tests/Unison/Test/ABT.hs index 2f36c15450..e32ddefac8 100644 --- a/parser-typechecker/tests/Unison/Test/ABT.hs +++ b/parser-typechecker/tests/Unison/Test/ABT.hs @@ -7,8 +7,6 @@ import EasyTest import Unison.ABT as ABT import Unison.Symbol (Symbol(..)) import Unison.Var as Var -import Unison.Codebase.Serialization ( getFromBytes, putBytes ) -import qualified Unison.Codebase.Serialization.V1 as V1 test :: Test () test = scope "abt" $ tests [ @@ -30,14 +28,7 @@ test = scope "abt" $ tests [ -- make sure the variable wasn't captured expectEqual fvs [symbol 0 "a"] -- make sure the resulting term is alpha equiv to \a1 -> [a1, a] - expectEqual t2 (ABT.abs (symbol 0 "b") (ABT.tm [var 0 "b", var 0 "a"])), - - -- confirmation of fix for https://github.com/unisonweb/unison/issues/1388 - -- where symbols with nonzero freshIds did not round trip - scope "putSymbol" $ let - v = Symbol 10 (User "hi") - v' = getFromBytes V1.getSymbol (putBytes V1.putSymbol v) - in expectEqual (Just v) v' + expectEqual t2 (ABT.abs (symbol 0 "b") (ABT.tm [var 0 "b", var 0 "a"])) ] where symbol i n = Symbol i (Var.User n) diff --git a/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs b/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs deleted file mode 100644 index a3b833f2d2..0000000000 --- a/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Test.BaseUpgradePushPullTest where - -import Data.String.Here.Interpolated (i) -import EasyTest -import Shellmet () -import qualified Unison.Test.Ucm as Ucm -import Unison.Test.GitSync (initGitRepo) - --- keep it off for CI, since the random temp dirs it generates show up in the --- output, which causes the test output to change, and the "no change" check --- to fail -writeTranscriptOutput :: Bool -writeTranscriptOutput = False - -test :: Test () -test = scope "base-upgrade-push-pull-test" do - io do - v1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - putStrLn =<< Ucm.runTranscript v1 [i| - ```ucm - .> pull /Users/arya/base _base - ``` - |] - v2 <- Ucm.upgradeCodebase v1 - repo <- initGitRepo - putStrLn =<< Ucm.runTranscript v2 [i| - ```ucm - .> push ${repo} _base - ``` - |] - v2' <- Ucm.initCodebase Ucm.CodebaseFormat2 - putStrLn $ show v2' - putStrLn =<< Ucm.runTranscript v2' [i| - ```ucm - .> pull ${repo} _base - .> test - ``` - |] - ok diff --git a/parser-typechecker/tests/Unison/Test/ClearCache.hs b/parser-typechecker/tests/Unison/Test/ClearCache.hs index 64bb1d4fcb..9538401b97 100644 --- a/parser-typechecker/tests/Unison/Test/ClearCache.hs +++ b/parser-typechecker/tests/Unison/Test/ClearCache.hs @@ -9,7 +9,7 @@ import Data.String.Here (i) import EasyTest import qualified Unison.Codebase as Codebase import qualified Unison.Test.Ucm as Ucm -import qualified Unison.Var as WatchKind +import qualified Unison.WatchKind as WatchKind test :: Test () test = scope "clearWatchCache" $ diff --git a/parser-typechecker/tests/Unison/Test/Codebase.hs b/parser-typechecker/tests/Unison/Test/Codebase.hs deleted file mode 100644 index ad46c853b6..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# Language OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Test.Codebase where - -import Data.Functor.Identity -import qualified Data.Map as Map -import Data.Map ( (!) ) -import EasyTest -import qualified Unison.Codebase as Codebase -import Unison.Codebase.CodeLookup ( CodeLookup(..) ) -import qualified Unison.Hash as Hash -import qualified Unison.Reference as R -import Unison.Symbol ( Symbol ) -import qualified Unison.Term as Term -import qualified Unison.UnisonFile as UF -import qualified Unison.Var as Var - -test :: Test () -test = scope "codebase" $ tests - [ scope "makeSelfContained" $ - let h = Hash.unsafeFromBase32Hex "abcd" - ref = R.Derived h 0 1 - v1 = Var.refNamed @Symbol ref - foo = Var.named "foo" - -- original binding: `foo = \v1 -> ref` - binding = (foo, Term.lam () v1 (Term.ref () ref)) - uf = UF.UnisonFileId mempty mempty [binding] mempty - code :: CodeLookup Symbol Identity () - code = CodeLookup - { getTerm = \rid -> pure $ - if R.DerivedId rid == ref then Just (Term.int () 42) - else Nothing - , getTypeDeclaration = \_ -> pure Nothing - } - -- expected binding after makeSelfContained: `foo = \v1 -> v2`, where `v2 /= v1` - UF.UnisonFile _ _ (Map.fromList -> bindings) _ = runIdentity $ Codebase.makeSelfContained' code uf - Term.LamNamed' _ (Term.Var' v2) = bindings ! foo - in expect $ v2 /= v1 - ] diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs index 2aa192a949..9681a2bea4 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs @@ -10,6 +10,7 @@ import Unison.Codebase.Causal ( Causal(Cons, Merge) , before ) import qualified Unison.Codebase.Causal as Causal +import qualified Unison.Codebase.Causal.FoldHistory as Causal import Control.Monad.Trans.State (State, state, put) import Data.Int (Int64) import qualified Data.Map as Map diff --git a/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs b/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs deleted file mode 100644 index 147477b48c..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Unison.Test.Codebase.FileCodebase where - -import EasyTest -import Unison.Codebase.FileCodebase.Common (encodeFileName, decodeFileName) -import qualified Data.Set as Set -import Data.Char as Char -import Data.Foldable (toList) - -test :: Test () -test = scope "FileCodebase" . tests $ - [ scope "encode/decodeFileName" . tests $ - [ encodeDecode "abc" - , encodeDecode "πŸ‘" - , encodeDecode "\xfff" - , tests $ encodeDecode . (:[]) <$> ['!'..'~'] - , encodeDecode ("Universal." ++ ['!'..'~']) - , specialEncode "." - , specialEncode ".." - , tests $ map specialEncodeChar (toList specificallyBadChars) - , specialEncodeChar 'πŸ‘' - , specialEncodeChar '\xfff' - ] - ] - -specialEncode :: String -> Test () -specialEncode s = - scope (" " <> s <> " gets special encoding") $ expect (encodeFileName s /= s) - -specialEncodeChar :: Char -> Test () -specialEncodeChar = specialEncode . pure - -encodeDecode :: String -> Test () -encodeDecode s = - let e = encodeFileName s - d = decodeFileName e - in scope s $ expect $ d == s && all isSafeChar e - --- In the past we had considered a much smaller set of safe chars: --- [0-9,a-z,A-Z,-._] from https://superuser.com/a/748264 --- Currently we are going by https://superuser.com/a/358861 -isSafeChar :: Char -> Bool -isSafeChar c = Set.notMember c specificallyBadChars - && Char.isPrint c - && Char.isAscii c - -specificallyBadChars :: Set.Set Char -specificallyBadChars = Set.fromList "\\/:*?\"<>|" - diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index e775fb489f..8776697843 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -4,6 +4,7 @@ module Unison.Test.Codebase.Path where import EasyTest import Unison.Codebase.Path +import Unison.Codebase.Path.Parse import Data.Sequence import Data.Text import Unison.NameSegment diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs b/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs deleted file mode 100644 index 506564add7..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - - -module Unison.Test.Codebase.Upgrade12 (test) where - -import Data.Functor (void) -import Data.String.Here.Interpolated (i) -import EasyTest (Test, expectJust, io, ok, scope, tests) -import Shellmet () -import qualified Unison.Codebase as Codebase -import qualified Unison.Test.Ucm as Ucm -import Unison.UnisonFile (pattern TestWatch) -import Debug.Trace (traceShowM) - -test :: Test () -test = scope "codebase.upgrade12" $ tests [ - scope "typeAlias" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - .> history - .> history builtin - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```unison - x : Nat - x = 3 - ``` - |] - ok, - - scope "topLevelTerm" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> find - ``` - ```unison - > y - ``` - |] - ok, - - scope "metadataForTerm" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 "" - Ucm.runTranscript c1 [i| - ```unison:hide - doc = "y is the number 3" - y = 3 - ``` - ```ucm - .> debug.file - .> add - .> link doc y - .> links y - .> history - ``` - |] - -- 8bbb doc - -- mps7 y - -- ttjf post-link - -- 988m pre-link - -- 7asf empty - Ucm.runTranscript c1 [i| - ```ucm - .> links y - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> links y - ``` - |] - ok, - - scope "metadataForType" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison:hide - doc = "Nat means natural number" - ``` - ```ucm - .> add - .> alias.type ##Nat Nat - .> link doc Nat - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> links Nat - ``` - |] - ok, - - scope "subNamespace" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison - unique type a.b.C = C Nat - ``` - ```ucm - .> add - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> find - ``` - ```unison - > a.b.C.C 3 - ``` - |] - ok, - - scope "accessPatch" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison:hide - unique type A = A Nat - foo = A.A 3 - ``` - ```ucm - .> debug.file - .> add - ``` - ```unison:hide - unique type A = A Nat Nat - foo = A.A 3 3 - ``` - ```ucm - .> debug.file - .> update - ``` - ```ucm - .> view.patch patch - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> view.patch patch - ``` - |] - ok, - --- #00k3c9bp6m A --- #6v94dtbfk1 foo --- #d3bn4dqp1a A' --- #p3a21bjjl4 foo' - - scope "history" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison - foo = 3 - ``` - ```ucm - .> add - ``` - ```unison - foo = 4 - ``` - ```ucm - .> update - .> history - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> history - .> reset-root #dsh - .> history - ``` - |] - ok, - - scope "test-watches" do - (watchTerms1, watchTerms2) <- io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> builtins.merge - ``` - ```unison - test> pass = [Ok "Passed"] - ``` - ```ucm - .> add - ``` - |] - (watches1, watchTerms1) <- Ucm.lowLevel c1 \c1' -> do - watches1@(_:_) <- Codebase.watches c1' TestWatch - watchTerms1 <- traverse (Codebase.getWatch c1' TestWatch) watches1 - pure (watches1, watchTerms1) - Ucm.runTranscript c1 [i| - ```unison - test> pass = [Ok "Passed"] - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - watchTerms2 <- Ucm.lowLevel c2 \c2' -> - traverse (Codebase.getWatch c2' TestWatch) watches1 - traceShowM watches1 - traceShowM watchTerms1 - traceShowM watchTerms2 - pure (watchTerms1, watchTerms2) - expectJust (sequence watchTerms1) - expectJust (sequence watchTerms2) - ok - ] diff --git a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs new file mode 100644 index 0000000000..d909b15e6d --- /dev/null +++ b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} + +module Unison.Test.CodebaseInit where + +import EasyTest +import qualified Unison.Codebase.Init as CI +import Unison.Codebase.Init + ( CodebaseInitOptions(..) + , Init(..) + , SpecifiedCodebase(..) + ) +import qualified System.IO.Temp as Temp + +-- keep it off for CI, since the random temp dirs it generates show up in the +-- output, which causes the test output to change, and the "no change" check +-- to fail +writeTranscriptOutput :: Bool +writeTranscriptOutput = False + +test :: Test () +test = scope "Codebase.Init" $ tests + [ scope "*without* a --codebase flag" $ tests + [ scope "a v2 codebase should be opened" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp)) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + , scope "a v2 codebase should be created when one does not exist" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp)) + case res of + CI.CreatedCodebase _ _ -> expect True + _ -> expect False + ] + , scope "*with* a --codebase flag" $ tests + [ scope "a v2 codebase should be opened" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp))) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + , scope "a v2 codebase should be *not* created when one does not exist at the Specified dir" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp))) + case res of + CI.Error _ CI.NoCodebaseFoundAtSpecifiedDir -> expect True + _ -> expect False + ] + , scope "*with* a --codebase-create flag" $ tests + [ scope "a v2 codebase should be created when one does not exist at the Specified dir" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) + case res of + CI.CreatedCodebase _ _ -> expect True + _ -> expect False + , + scope "a v2 codebase should be opened when one exists" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + ] + ] + +-- Test helpers + +initMockWithCodebase :: IO (Init IO v a) +initMockWithCodebase = do + let codebase = error "did we /actually/ need a Codebase?" + pure $ Init { + -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + openCodebase = \_ _ -> pure ( Right (pure (), codebase)), + -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + createCodebase' = \_ _ -> pure (Right (pure (), codebase)), + -- CodebasePath -> CodebasePath + codebasePath = id + } + +initMockWithoutCodebase :: IO (Init IO v a) +initMockWithoutCodebase = do + let codebase = error "did we /actually/ need a Codebase?" + pure $ Init { + -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + openCodebase = \_ _ -> pure (Left "no codebase found"), + -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + createCodebase' = \_ _ -> pure (Right (pure (), codebase)), + -- CodebasePath -> CodebasePath + codebasePath = id + } \ No newline at end of file diff --git a/parser-typechecker/tests/Unison/Test/Common.hs b/parser-typechecker/tests/Unison/Test/Common.hs index 2c078fdb3b..46517fdefe 100644 --- a/parser-typechecker/tests/Unison/Test/Common.hs +++ b/parser-typechecker/tests/Unison/Test/Common.hs @@ -12,7 +12,7 @@ import Data.Sequence (Seq) import qualified Data.Text as Text import qualified Unison.Builtin as B import qualified Unison.FileParsers as FP -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import Unison.PrintError ( prettyParseError ) import Unison.Result (Result, Note) import Unison.Symbol (Symbol) diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 40824ecb50..c4dddf56b6 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -2,25 +2,27 @@ module Unison.Test.DataDeclaration where -import qualified Data.Map as Map -import Data.Map ( Map, (!) ) -import EasyTest -import Text.RawString.QQ +import Data.Map (Map, (!)) +import qualified Data.Map as Map +import EasyTest +import Text.RawString.QQ +import Unison.DataDeclaration (DataDeclaration (..), Decl) import qualified Unison.DataDeclaration as DD -import Unison.DataDeclaration ( DataDeclaration(..), Decl, hashDecls ) -import qualified Unison.Hash as Hash -import Unison.Parser ( Ann ) -import Unison.Parsers ( unsafeParseFile ) -import qualified Unison.Reference as R -import Unison.Symbol ( Symbol ) -import qualified Unison.Test.Common as Common -import qualified Unison.Type as Type -import Unison.UnisonFile ( UnisonFile(..) ) -import qualified Unison.Var as Var +import qualified Unison.Hash as Hash +import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.Parser.Ann (Ann) +import Unison.Parsers (unsafeParseFile) +import qualified Unison.Reference as R +import Unison.Symbol (Symbol) +import qualified Unison.Test.Common as Common +import qualified Unison.Type as Type +import Unison.UnisonFile (UnisonFile (..)) +import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var test :: Test () test = scope "datadeclaration" $ - let Right hashes = hashDecls . (snd <$>) . dataDeclarationsId $ file + let Right hashes = Hashing.hashDecls . (snd <$>) . dataDeclarationsId $ file hashMap = Map.fromList $ fmap (\(a,b,_) -> (a,b)) hashes hashOf k = Map.lookup (Var.named k) hashMap in tests [ @@ -38,23 +40,23 @@ test = scope "datadeclaration" $ file :: UnisonFile Symbol Ann file = flip unsafeParseFile Common.parsingEnv $ [r| -type Bool = True | False -type Bool' = False | True +structural type Bool = True | False +structural type Bool' = False | True -type Option a = Some a | None -type Option' b = Nothing | Just b +structural type Option a = Some a | None +structural type Option' b = Nothing | Just b -type List a = Nil | Cons a (List a) -type List' b = Prepend b (List' b) | Empty -type SnocList a = Snil | Snoc (List a) a +structural type List a = Nil | Cons a (List a) +structural type List' b = Prepend b (List' b) | Empty +structural type SnocList a = Snil | Snoc (List a) a -type ATree a = Tree a (List (ATree a)) | Leaf (Option a) +structural type ATree a = Tree a (List (ATree a)) | Leaf (Option a) -type Ping a = Ping a (Pong a) -type Pong a = Pnong | Pong (Ping a) +structural type Ping a = Ping a (Pong a) +structural type Pong a = Pnong | Pong (Ping a) -type Long' a = Long' (Ling' a) | Lnong -type Ling' a = Ling' a (Long' a) +structural type Long' a = Long' (Ling' a) | Lnong +structural type Ling' a = Ling' a (Long' a) |] diff --git a/parser-typechecker/tests/Unison/Test/FileParser.hs b/parser-typechecker/tests/Unison/Test/FileParser.hs index f45a6298a6..582d636bc9 100644 --- a/parser-typechecker/tests/Unison/Test/FileParser.hs +++ b/parser-typechecker/tests/Unison/Test/FileParser.hs @@ -8,6 +8,7 @@ module Unison.Test.FileParser where import qualified Text.Megaparsec.Error as MPE import Unison.FileParser (file) import qualified Unison.Parser as P + import qualified Unison.Parser.Ann as P import Unison.Parsers (unsafeGetRightFrom, unsafeParseFileBuiltinsOnly) import Unison.Symbol (Symbol) import Unison.UnisonFile (UnisonFile) @@ -18,25 +19,25 @@ module Unison.Test.FileParser where test1 = scope "test1" . tests . map parses $ [ -- , "type () = ()\n()" - "type Pair a b = Pair a b\n" - , "type Optional a = Just a | Nothing\n" + "structural type Pair a b = Pair a b\n" + , "structural type Optional a = Just a | Nothing\n" , unlines - ["type Optional2 a" + ["structural type Optional2 a" ," = Just a" ," | Nothing\n"] ------ -- ,unlines - ------ -- ["type Optional a b c where" + ------ -- ["structural type Optional a b c where" ------ -- ," Just : a -> Optional a" ------ -- ," Nothing : Optional Int"] ------ -- , unlines - ------ -- ["type Optional" + ------ -- ["structural type Optional" ------ -- ," a" ------ -- ," b" ------ -- ," c where" ------ -- ," Just : a -> Optional a" ------ -- ," Nothing : Optional Int"] , unlines -- NB: this currently fails because we don't have type AST or parser for effect types yet - ["ability State s where" + ["structural ability State s where" ," get : {State s} s" ," set : s -> {State s} ()" ] diff --git a/parser-typechecker/tests/Unison/Test/GitSync.hs b/parser-typechecker/tests/Unison/Test/GitSync.hs index a5b4fe88d6..64e36fd2bd 100644 --- a/parser-typechecker/tests/Unison/Test/GitSync.hs +++ b/parser-typechecker/tests/Unison/Test/GitSync.hs @@ -15,12 +15,12 @@ import System.FilePath (()) import qualified System.IO.Temp as Temp import qualified Unison.Codebase as Codebase import Unison.Codebase (Codebase) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Symbol (Symbol) import Unison.Test.Ucm (CodebaseFormat, Transcript) import qualified Unison.Test.Ucm as Ucm -import Unison.UnisonFile (pattern TestWatch) +import Unison.WatchKind (pattern TestWatch) -- keep it off for CI, since the random temp dirs it generates show up in the -- output, which causes the test output to change, and the "no change" check @@ -33,7 +33,7 @@ test = scope "gitsync22" . tests $ fastForwardPush : nonFastForwardPush : destroyedRemote : - flip map [(Ucm.CodebaseFormat1 , "fc"), (Ucm.CodebaseFormat2, "sc")] + flip map [(Ucm.CodebaseFormat2, "sc")] \(fmt, name) -> scope name $ tests [ pushPullTest "typeAlias" fmt (\repo -> [i| @@ -132,7 +132,7 @@ test = scope "gitsync22" . tests $ |]) (\repo -> [i| ```ucm - .> pull ${repo} + .> pull.silent ${repo} .> find ``` ```unison @@ -168,7 +168,7 @@ test = scope "gitsync22" . tests $ |]) (\repo -> [i| ```ucm - .> pull ${repo} + .> pull.silent ${repo} .> view.patch patch ``` |]) @@ -249,7 +249,7 @@ test = scope "gitsync22" . tests $ -- simplest-author (\repo -> [i| ```unison - type Foo = Foo + structural type Foo = Foo ``` ```ucm .myLib> debug.file @@ -322,8 +322,8 @@ test = scope "gitsync22" . tests $ .> builtins.merge ``` ```unison - type A = A Nat - type B = B Int + structural type A = A Nat + structural type B = B Int x = 3 y = 4 ``` diff --git a/parser-typechecker/tests/Unison/Test/Lexer.hs b/parser-typechecker/tests/Unison/Test/Lexer.hs index b1cd43212b..a048309bcf 100644 --- a/parser-typechecker/tests/Unison/Test/Lexer.hs +++ b/parser-typechecker/tests/Unison/Test/Lexer.hs @@ -64,10 +64,10 @@ test = , t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close] , t "[+1,+1]" - [Reserved "[", Numeric "+1", Reserved ",", Numeric "+1", Reserved "]"] + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close ] , t "[ +1 , +1 ]" - [Reserved "[", Numeric "+1", Reserved ",", Numeric "+1", Reserved "]"] + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close ] , t "-- a comment 1.0" [] , t "\"woot\" -- a comment 1.0" [Textual "woot"] , t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"] diff --git a/parser-typechecker/tests/Unison/Test/Term.hs b/parser-typechecker/tests/Unison/Test/Term.hs index 5afdad551d..14b39e34df 100644 --- a/parser-typechecker/tests/Unison/Test/Term.hs +++ b/parser-typechecker/tests/Unison/Test/Term.hs @@ -11,6 +11,7 @@ import Unison.Symbol ( Symbol ) import qualified Unison.Term as Term import qualified Unison.Type as Type import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var test :: Test () test = scope "term" $ tests diff --git a/parser-typechecker/tests/Unison/Test/TermPrinter.hs b/parser-typechecker/tests/Unison/Test/TermPrinter.hs old mode 100755 new mode 100644 index 313f79c57b..e51bc37660 --- a/parser-typechecker/tests/Unison/Test/TermPrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TermPrinter.hs @@ -12,9 +12,10 @@ import Unison.TermPrinter import qualified Unison.Type as Type import Unison.Symbol (Symbol, symbol) import qualified Unison.Builtin -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import qualified Unison.Util.Pretty as PP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.Util.ColorText as CT import Unison.Test.Common (t, tm) import qualified Unison.Test.Common as Common @@ -343,13 +344,13 @@ test = scope "termprinter" $ tests , tc "!f a" , tcDiff "f () a ()" "!(!f a)" , tcDiff "f a b ()" "!(f a b)" - , tcDiff "!f ()" "!(!f)" - , tc "!(!foo)" + , tcDiff "!f ()" "!!f" + , tcDiff "!(!foo)" "!!foo" , tc "'bar" , tc "'(bar a b)" - , tc "'('bar)" - , tc "!('bar)" - , tc "'(!foo)" + , tcDiff "'('bar)" "''bar" + , tcDiff "!('bar)" "!'bar" + , tcDiff "'(!foo)" "'!foo" , tc "x -> '(y -> 'z)" , tc "'(x -> '(y -> z))" , tc "(\"a\", 2)" @@ -369,7 +370,7 @@ test = scope "termprinter" $ tests , pending $ tc "match x with [a] -> a" -- ditto , pending $ tc "match x with [] -> a" -- ditto , tcDiff "match x with Optional.Some (Optional.Some _) -> ()" - "let\n Optional.Some (Optional.Some _) = x\n ()" + "let\n (Optional.Some (Optional.Some _)) = x\n ()" -- need an actual effect constructor to test the following , pending $ tc "match x with { SomeRequest (Optional.Some _) -> k } -> ()" , tcBinding 50 "foo" (Just "Int") "3" "foo : Int\n\ diff --git a/parser-typechecker/tests/Unison/Test/TypePrinter.hs b/parser-typechecker/tests/Unison/Test/TypePrinter.hs old mode 100755 new mode 100644 index 0c03f8ad0c..4995bc6214 --- a/parser-typechecker/tests/Unison/Test/TypePrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TypePrinter.hs @@ -6,7 +6,7 @@ import Unison.TypePrinter import qualified Unison.Builtin import Unison.Util.ColorText (toPlain) import qualified Unison.Util.Pretty as PP -import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.Test.Common as Common @@ -134,8 +134,7 @@ test = scope "typeprinter" . tests $ , tc "'{e} a" , tc "'{e} (a -> b)" , tc "'{e} (a ->{f} b)" - , pending $ tc "Pair a '{e} b" -- parser hits unexpected ' - , tc_diff_rtt False "Pair a ('{e} b)" "Pair a '{e} b" 80 -- no RTT due to the above + , tc "Pair a ('{e} b)" , tc "'(a -> 'a)" , tc "'()" , tc "'('a)" diff --git a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs index 5c4b90adb6..7f64af1f39 100644 --- a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs +++ b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs @@ -5,7 +5,7 @@ module Unison.Test.Typechecker.TypeError where import Data.Foldable (toList) import Data.Maybe (isJust) import EasyTest -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Result (pattern Result) import qualified Unison.Result as Result import Unison.Symbol (Symbol) @@ -32,7 +32,7 @@ test = scope "> extractor" . tests $ , n "> match 3 with 3 | 3 -> 3" Err.matchBody , y "> 1 1" Err.applyingNonFunction , y "> 1 Int.+ 1" Err.applyingFunction - , y ( "ability Abort where\n" ++ + , y ( "structural ability Abort where\n" ++ " abort : {Abort} a\n" ++ "\n" ++ "xyz : t -> Request Abort t -> t\n" ++ diff --git a/parser-typechecker/tests/Unison/Test/Ucm.hs b/parser-typechecker/tests/Unison/Test/Ucm.hs index 01349f6588..5d58f1bd2b 100644 --- a/parser-typechecker/tests/Unison/Test/Ucm.hs +++ b/parser-typechecker/tests/Unison/Test/Ucm.hs @@ -6,11 +6,11 @@ module Unison.Test.Ucm ( initCodebase, deleteCodebase, runTranscript, - upgradeCodebase, lowLevel, CodebaseFormat (..), Transcript, unTranscript, + Codebase (..), ) where @@ -22,18 +22,16 @@ import qualified System.IO.Temp as Temp import U.Util.String (stripMargin) import Unison.Codebase (CodebasePath) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Conversion.Upgrade12 as Upgrade12 -import qualified Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Init as Codebase.Init import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR import Unison.Prelude (traceM) import qualified Unison.PrettyTerminal as PT import qualified Unison.Util.Pretty as P -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Symbol (Symbol) -data CodebaseFormat = CodebaseFormat1 | CodebaseFormat2 deriving (Show, Enum, Bounded) +data CodebaseFormat = CodebaseFormat2 deriving (Show, Enum, Bounded) data Codebase = Codebase CodebasePath CodebaseFormat deriving (Show) @@ -50,7 +48,7 @@ debugTranscriptOutput = False initCodebase :: CodebaseFormat -> IO Codebase initCodebase fmt = do - let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + let cbInit = case fmt of CodebaseFormat2 -> SC.init tmp <- Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test" @@ -62,13 +60,6 @@ initCodebase fmt = do deleteCodebase :: Codebase -> IO () deleteCodebase (Codebase path _) = removeDirectoryRecursive path -upgradeCodebase :: Codebase -> IO Codebase -upgradeCodebase = \case - c@(Codebase _ CodebaseFormat2) -> fail $ show c ++ " already in V2 format." - Codebase path CodebaseFormat1 -> do - Upgrade12.upgradeCodebase path - pure $ Codebase path CodebaseFormat2 - runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do -- this configFile ought to be optional @@ -78,7 +69,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do >>= flip Temp.createTempDirectory ("ucm-test") pure $ tmpDir ".unisonConfig" let err err = fail $ "Parse error: \n" <> show err - cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + cbInit = case fmt of CodebaseFormat2 -> SC.init (closeCodebase, codebase) <- Codebase.Init.openCodebase cbInit "transcript" codebasePath >>= \case Left e -> fail $ P.toANSI 80 e @@ -99,7 +90,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a lowLevel (Codebase root fmt) f = do - let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + let cbInit = case fmt of CodebaseFormat2 -> SC.init Codebase.Init.openCodebase cbInit "lowLevel" root >>= \case Left p -> PT.putPrettyLn p *> pure (error "This really should have loaded") Right (close, cb) -> f cb <* close diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 5a3d795153..700ae12097 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -6,7 +6,6 @@ module Unison.Test.UnisonSources where import Control.Exception (throwIO) import Control.Lens ( view ) import Control.Lens.Tuple ( _5 ) -import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.Map as Map import Data.Sequence (Seq) @@ -16,33 +15,26 @@ import EasyTest import System.FilePath (joinPath, splitPath, replaceExtension) import System.FilePath.Find (always, extension, find, (==?)) import System.Directory ( doesFileExist ) -import qualified Unison.ABT as ABT import qualified Unison.Builtin as Builtin import Unison.Codebase.Runtime ( Runtime, evaluateWatches ) -import Unison.Codebase.Serialization ( getFromBytes, putBytes ) -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.DataDeclaration (EffectDeclaration, DataDeclaration) -import Unison.Parser as Parser +import Unison.Parser.Ann (Ann) import qualified Unison.Parsers as Parsers import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.PrintError as PrintError -import Unison.Reference ( Reference ) import Unison.Result (pattern Result, Result) import qualified Unison.Result as Result import qualified Unison.Runtime.Interface as RTI import Unison.Symbol (Symbol) import qualified Unison.Term as Term -import Unison.Term ( Term ) import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv) -import Unison.Type ( Type ) import qualified Unison.UnisonFile as UF import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty (toPlain) -import qualified Unison.Var as Var import qualified Unison.Test.Common as Common import qualified Unison.Names3 -type Note = Result.Note Symbol Parser.Ann +type Note = Result.Note Symbol Ann type TFile = UF.TypecheckedUnisonFile Symbol Ann type SynthResult = @@ -118,7 +110,7 @@ makePassingTest :: Runtime Symbol -> (EitherResult -> Test TFile) -> FilePath -> Test () makePassingTest rt how filepath = scope (shortName filepath) $ do uf <- typecheckingTest how filepath - resultTest rt uf filepath *> serializationTest uf + resultTest rt uf filepath shortName :: FilePath -> FilePath shortName = joinPath . drop 1 . splitPath @@ -136,7 +128,6 @@ resultTest rt uf filepath = do if rFileExists then scope "result" $ do values <- io $ unpack <$> Data.Text.IO.readFile valueFile - let untypedFile = UF.discardTypes uf let term = Parsers.parseTerm values parsingEnv let report e = throwIO (userError $ toPlain 10000 e) (bindings, watches) <- io $ either report pure =<< @@ -144,7 +135,7 @@ resultTest rt uf filepath = do mempty (const $ pure Nothing) rt - untypedFile + uf case term of Right tm -> do -- compare the the watch expression from the .u with the expr in .ur @@ -156,42 +147,3 @@ resultTest rt uf filepath = do Left e -> crash $ show e else pure () -serializationTest :: TFile -> Test () -serializationTest uf = scope "serialization" . tests . concat $ - [ map testDataDeclaration (Map.toList $ UF.dataDeclarations' uf) - , map testEffectDeclaration (Map.toList $ UF.effectDeclarations' uf) - , map testTerm (Map.toList $ UF.hashTerms uf) - ] - where - putUnit :: Monad m => () -> m () - putUnit () = pure () - getUnit :: Monad m => m () - getUnit = pure () - testDataDeclaration :: (Symbol, (Reference, DataDeclaration Symbol Ann)) -> Test () - testDataDeclaration (name, (_, decl)) = scope (Var.nameStr name) $ - let decl' :: DataDeclaration Symbol () - decl' = void decl - bytes = putBytes (V1.putDataDeclaration V1.putSymbol putUnit) decl' - decl'' = getFromBytes (V1.getDataDeclaration V1.getSymbol getUnit) bytes - in expectEqual decl'' (Just decl') - testEffectDeclaration :: (Symbol, (Reference, EffectDeclaration Symbol Ann)) -> Test () - testEffectDeclaration (name, (_, decl)) = scope (Var.nameStr name) $ - let decl' :: EffectDeclaration Symbol () - decl' = void decl - bytes = putBytes (V1.putEffectDeclaration V1.putSymbol putUnit) decl' - decl'' = getFromBytes (V1.getEffectDeclaration V1.getSymbol getUnit) bytes - in expectEqual decl'' (Just decl') - testTerm :: (Symbol, (Reference, Term Symbol Ann, Type Symbol Ann)) -> Test () - testTerm (name, (_, tm, tp)) = scope (Var.nameStr name) $ - let tm' :: Term Symbol () - tm' = Term.amap (const ()) tm - tp' :: Type Symbol () - tp' = ABT.amap (const ()) tp - tmBytes = putBytes (V1.putTerm V1.putSymbol putUnit) tm' - tpBytes = putBytes (V1.putType V1.putSymbol putUnit) tp' - tm'' = getFromBytes (V1.getTerm V1.getSymbol getUnit) tmBytes - tp'' = getFromBytes (V1.getType V1.getSymbol getUnit) tpBytes - in tests - [ scope "type" $ expectEqual tp'' (Just tp') - , scope "term" $ expectEqual tm'' (Just tm') - ] diff --git a/parser-typechecker/tests/Unison/Test/VersionParser.hs b/parser-typechecker/tests/Unison/Test/VersionParser.hs index b5e62bdfea..d4c9944687 100644 --- a/parser-typechecker/tests/Unison/Test/VersionParser.hs +++ b/parser-typechecker/tests/Unison/Test/VersionParser.hs @@ -13,7 +13,7 @@ test :: Test () test = scope "versionparser" . tests . fmap makeTest $ [ ("release/M1j", "releases._M1j") , ("release/M1j.2", "releases._M1j") - , ("devel/M1k", "trunk") + , ("latest-abc", "trunk") ] makeTest :: (Text, Text) -> Test () diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 99266cb3bf..aab48f91df 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -28,13 +28,16 @@ library Unison.Builtin.Terms Unison.Codebase Unison.Codebase.Branch + Unison.Codebase.Branch.Merge + Unison.Codebase.Branch.Names Unison.Codebase.BranchDiff Unison.Codebase.BranchUtil + Unison.Codebase.BuiltinAnnotation Unison.Codebase.Causal - Unison.Codebase.Classes + Unison.Codebase.Causal.FoldHistory Unison.Codebase.CodeLookup + Unison.Codebase.CodeLookup.Util Unison.Codebase.Conversion.Sync12 - Unison.Codebase.Conversion.Upgrade12 Unison.Codebase.Editor.AuthorInfo Unison.Codebase.Editor.Command Unison.Codebase.Editor.DisplayObject @@ -54,46 +57,73 @@ library Unison.Codebase.Editor.VersionParser Unison.Codebase.Execute Unison.Codebase.FileCodebase - Unison.Codebase.FileCodebase.Branch.Dependencies - Unison.Codebase.FileCodebase.Common - Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex Unison.Codebase.GitError Unison.Codebase.Init + Unison.Codebase.Init.CreateCodebaseError + Unison.Codebase.Init.Type Unison.Codebase.MainTerm Unison.Codebase.Metadata - Unison.Codebase.NameEdit Unison.Codebase.Patch Unison.Codebase.Path + Unison.Codebase.Path.Parse Unison.Codebase.Reflog Unison.Codebase.Runtime Unison.Codebase.Serialization - Unison.Codebase.Serialization.PutT - Unison.Codebase.Serialization.V1 Unison.Codebase.ShortBranchHash Unison.Codebase.SqliteCodebase Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Conversions + Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.SyncMode Unison.Codebase.TermEdit + Unison.Codebase.TermEdit.Typing Unison.Codebase.TranscriptParser + Unison.Codebase.Type Unison.Codebase.TypeEdit + Unison.Codebase.Verbosity Unison.Codebase.Watch + Unison.CodebasePath Unison.CommandLine Unison.CommandLine.DisplayValues Unison.CommandLine.InputPattern Unison.CommandLine.InputPatterns Unison.CommandLine.Main Unison.CommandLine.OutputMessages + Unison.CommandLine.Welcome Unison.DeclPrinter Unison.FileParser Unison.FileParsers + Unison.Hashing.V1.Convert + Unison.Hashing.V1.DataDeclaration + Unison.Hashing.V1.LabeledDependency + Unison.Hashing.V1.Pattern + Unison.Hashing.V1.Reference + Unison.Hashing.V1.Reference.Util + Unison.Hashing.V1.Referent + Unison.Hashing.V1.Term + Unison.Hashing.V1.Type + Unison.Hashing.V2.Convert + Unison.Hashing.V2.DataDeclaration + Unison.Hashing.V2.LabeledDependency + Unison.Hashing.V2.Pattern + Unison.Hashing.V2.Reference + Unison.Hashing.V2.Reference.Util + Unison.Hashing.V2.Referent + Unison.Hashing.V2.Term + Unison.Hashing.V2.Type Unison.Lexer + Unison.Lexer.Pos Unison.NamePrinter Unison.Parser + Unison.Parser.Ann Unison.Parsers - Unison.Path Unison.PrettyPrintEnv + Unison.PrettyPrintEnv.FQN + Unison.PrettyPrintEnv.Names + Unison.PrettyPrintEnv.Util + Unison.PrettyPrintEnvDecl + Unison.PrettyPrintEnvDecl.Names Unison.PrettyTerminal Unison.PrintError Unison.Result @@ -118,7 +148,8 @@ library Unison.Server.Doc Unison.Server.Endpoints.FuzzyFind Unison.Server.Endpoints.GetDefinitions - Unison.Server.Endpoints.ListNamespace + Unison.Server.Endpoints.NamespaceDetails + Unison.Server.Endpoints.NamespaceListing Unison.Server.Errors Unison.Server.QueryResult Unison.Server.SearchResult @@ -137,9 +168,14 @@ library Unison.TypeParser Unison.TypePrinter Unison.UnisonFile + Unison.UnisonFile.Env + Unison.UnisonFile.Error + Unison.UnisonFile.Names + Unison.UnisonFile.Type Unison.Util.AnnotatedText Unison.Util.Bytes Unison.Util.ColorText + Unison.Util.Convert Unison.Util.CycleTable Unison.Util.CyclicEq Unison.Util.CyclicOrd @@ -150,7 +186,6 @@ library Unison.Util.Less Unison.Util.Logger Unison.Util.Map - Unison.Util.Menu Unison.Util.PinBoard Unison.Util.Pretty Unison.Util.Range @@ -193,6 +228,7 @@ library , cryptonite , data-default , data-memocombinators + , deepseq , directory , either , errors @@ -223,6 +259,7 @@ library , openapi3 , optparse-applicative >=0.16.1.0 , pem + , prelude-extras , primitive , process , random >=1.2.0 @@ -262,6 +299,7 @@ library , x509 , x509-store , x509-system + , zlib if flag(optimized) ghc-options: -funbox-strict-fields -O2 default-language: Haskell2010 @@ -301,14 +339,11 @@ executable tests Unison.Core.Test.Name Unison.Test.ABT Unison.Test.ANF - Unison.Test.BaseUpgradePushPullTest Unison.Test.Cache Unison.Test.ClearCache - Unison.Test.Codebase Unison.Test.Codebase.Causal - Unison.Test.Codebase.FileCodebase Unison.Test.Codebase.Path - Unison.Test.Codebase.Upgrade12 + Unison.Test.CodebaseInit Unison.Test.ColorText Unison.Test.Common Unison.Test.DataDeclaration @@ -404,6 +439,8 @@ executable transcripts TupleSections TypeApplications ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -threaded -rtsopts -with-rtsopts=-N -v0 + build-tools: + unison build-depends: base , directory @@ -462,6 +499,7 @@ executable unison , unison-codebase-sync , unison-core1 , unison-parser-typechecker + , unliftio , uri-encode if flag(optimized) ghc-options: -funbox-strict-fields -O2 diff --git a/parser-typechecker/unison/ArgParse.hs b/parser-typechecker/unison/ArgParse.hs index f6671d7067..632a2ae1dd 100644 --- a/parser-typechecker/unison/ArgParse.hs +++ b/parser-typechecker/unison/ArgParse.hs @@ -24,7 +24,6 @@ import Options.Applicative , command , customExecParser , flag - , flag' , footerDoc , fullDesc , headerDoc @@ -70,11 +69,21 @@ data ShouldForkCodebase | DontFork deriving (Show, Eq) +data ShouldDownloadBase + = ShouldDownloadBase + | ShouldNotDownloadBase + deriving (Show, Eq) + data ShouldSaveCodebase = SaveCodebase | DontSaveCodebase deriving (Show, Eq) +data CodebasePathOption + = CreateCodebaseWhenMissing FilePath + | DontCreateCodebaseWhenMissing FilePath + deriving (Show, Eq) + data IsHeadless = Headless | WithCLI deriving (Show, Eq) @@ -83,23 +92,17 @@ data IsHeadless = Headless | WithCLI -- Note that this is not one-to-one with command-parsers since some are simple variants. -- E.g. run, run.file, run.pipe data Command - = Launch IsHeadless CodebaseServerOpts + = Launch IsHeadless CodebaseServerOpts ShouldDownloadBase | PrintVersion + -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released | Init | Run RunSource | Transcript ShouldForkCodebase ShouldSaveCodebase (NonEmpty FilePath ) - | UpgradeCodebase deriving (Show, Eq) -data CodebaseFormat - = V1 - | V2 - deriving (Show, Eq) - -- | Options shared by sufficiently many subcommands. data GlobalOptions = GlobalOptions - { codebasePath :: Maybe FilePath - , codebaseFormat :: CodebaseFormat + { codebasePathOption :: Maybe CodebasePathOption } deriving (Show, Eq) -- | The root-level 'ParserInfo'. @@ -146,7 +149,8 @@ versionCommand = command "version" (info versionParser (fullDesc <> progDesc "Pr initCommand :: Mod CommandFields Command initCommand = command "init" (info initParser (progDesc initHelp)) where - initHelp = "Initialise a unison codebase" + initHelp = + "This command is has been removed. Use --codebase-create instead to create a codebase in the specified directory when starting the UCM." runSymbolCommand :: Mod CommandFields Command runSymbolCommand = @@ -184,10 +188,6 @@ transcriptForkCommand = , "Multiple transcript files may be provided; they are processed in sequence" <+> "starting from the same codebase." ] -upgradeCodebaseCommand :: Mod CommandFields Command -upgradeCodebaseCommand = - command "upgrade-codebase" (info (pure UpgradeCodebase) (fullDesc <> progDesc "Upgrades a v1 codebase to a v2 codebase")) - commandParser :: CodebaseServerOpts -> Parser Command commandParser envOpts = hsubparser commands <|> launchParser envOpts WithCLI @@ -200,28 +200,30 @@ commandParser envOpts = , runPipeCommand , transcriptCommand , transcriptForkCommand - , upgradeCodebaseCommand , launchHeadlessCommand envOpts ] - + globalOptionsParser :: Parser GlobalOptions globalOptionsParser = do -- ApplicativeDo - codebasePath <- codebasePathParser - codebaseFormat <- codebaseFormatParser - pure GlobalOptions{..} + codebasePathOption <- codebasePathParser <|> codebaseCreateParser -codebasePathParser :: Parser (Maybe FilePath) -codebasePathParser = - optional . strOption $ - long "codebase" - <> metavar "path/to/codebase" - <> help "The path to the codebase, defaults to the home directory" + pure GlobalOptions{codebasePathOption = codebasePathOption} -codebaseFormatParser :: Parser CodebaseFormat -codebaseFormatParser = - flag' V1 (long "old-codebase" <> help "Use a v1 codebase on startup.") - <|> flag' V2 (long "new-codebase" <> help "Use a v2 codebase on startup.") - <|> pure V2 +codebasePathParser :: Parser (Maybe CodebasePathOption) +codebasePathParser = do + optString <- optional . strOption $ + long "codebase" + <> metavar "codebase/path" + <> help "The path to an existing codebase" + pure (fmap DontCreateCodebaseWhenMissing optString) + +codebaseCreateParser :: Parser (Maybe CodebasePathOption) +codebaseCreateParser = do + path <- optional . strOption $ + long "codebase-create" + <> metavar "codebase/path" + <> help "The path to a new or existing codebase (one will be created if there isn't one)" + pure (fmap CreateCodebaseWhenMissing path) launchHeadlessCommand :: CodebaseServerOpts -> Mod CommandFields Command launchHeadlessCommand envOpts = @@ -266,10 +268,11 @@ codebaseServerOptsParser envOpts = do -- ApplicativeDo launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command launchParser envOpts isHeadless = do -- ApplicativeDo codebaseServerOpts <- codebaseServerOptsParser envOpts - pure (Launch isHeadless codebaseServerOpts) + downloadBase <- downloadBaseFlag + pure (Launch isHeadless codebaseServerOpts downloadBase) initParser :: Parser Command -initParser = pure Init +initParser = pure Init versionParser :: Parser Command versionParser = pure PrintVersion @@ -293,6 +296,11 @@ saveCodebaseFlag = flag DontSaveCodebase SaveCodebase (long "save-codebase" <> h where saveHelp = "if set the resulting codebase will be saved to a new directory, otherwise it will be deleted" +downloadBaseFlag :: Parser ShouldDownloadBase +downloadBaseFlag = flag ShouldDownloadBase ShouldNotDownloadBase (long "no-base" <> help downloadBaseHelp) + where + downloadBaseHelp = "if set, a new codebase will be created without downloading the base library, otherwise the new codebase will download base" + fileArgument :: String -> Parser FilePath fileArgument varName = strArgument ( metavar varName diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 9026d9ef0f..56b4bafda6 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -22,18 +22,19 @@ import qualified System.IO.Temp as Temp import qualified System.Path as Path import Text.Megaparsec (runParser) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Init as Codebase +import Unison.Codebase.Init (InitResult(..), InitError(..), CodebaseInitOptions(..), SpecifiedCodebase(..)) +import qualified Unison.Codebase.Init as CodebaseInit import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) -import qualified Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR import Unison.CommandLine (plural', watchConfig) +import qualified Unison.CommandLine.Welcome as Welcome import qualified Unison.CommandLine.Main as CommandLine -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Codebase.Runtime as Rt import qualified Unison.PrettyTerminal as PT @@ -42,24 +43,22 @@ import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import qualified Version -import qualified Unison.Codebase.Conversion.Upgrade12 as Upgrade12 +import UnliftIO.Directory ( getHomeDirectory ) import Compat ( installSignalHandlers ) import ArgParse ( UsageRenderer, - GlobalOptions(GlobalOptions, codebasePath, codebaseFormat), - CodebaseFormat(..), - Command(Launch, PrintVersion, Init, Run, Transcript, - UpgradeCodebase), + GlobalOptions(GlobalOptions, codebasePathOption), + Command(Launch, PrintVersion, Init, Run, Transcript), IsHeadless(WithCLI, Headless), ShouldSaveCodebase(..), ShouldForkCodebase(..), + ShouldDownloadBase (..), + CodebasePathOption(..), RunSource(RunFromPipe, RunFromSymbol, RunFromFile), parseCLIArgs ) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty - -cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann -cbInitFor = \case V1 -> FC.init; V2 -> SC.init +import Unison.CommandLine.Welcome (CodebaseInitStatus(..)) main :: IO () main = do @@ -68,8 +67,9 @@ main = do void installSignalHandlers (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribe - let GlobalOptions{codebasePath=mcodepath, codebaseFormat=cbFormat} = globalOptions - let cbInit = cbInitFor cbFormat + let GlobalOptions{codebasePathOption=mCodePathOption} = globalOptions + let mcodepath = fmap codebasePathOptionToPath mCodePathOption + currentDir <- getCurrentDirectory configFilePath <- getConfigFilePath mcodepath config <- @@ -78,10 +78,21 @@ main = do case command of PrintVersion -> putStrLn $ progName ++ " version: " ++ Version.gitDescribe - Init -> - Codebase.initCodebaseAndExit cbInit "main.init" mcodepath + Init -> do + PT.putPrettyLn $ + P.callout + "⚠️" + (P.lines ["The Init command has been removed" + , P.newline + , P.wrap "Use --codebase-create to create a codebase at a specified location and open it:" + , P.indentN 2 (P.hiBlue "$ ucm --codebase-create myNewCodebase") + , "Running UCM without the --codebase-create flag: " + , P.indentN 2 (P.hiBlue "$ ucm") + , P.wrap ("will " <> P.bold "always" <> " create a codebase in your home directory if one does not already exist.") + ]) + Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + ((closeCodebase, theCodebase),_) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -92,37 +103,42 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing + launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes closeCodebase Run (RunFromPipe mainName) -> do e <- safeReadUtf8StdIn case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing + ShouldNotDownloadBase + initRes closeCodebase Transcript shouldFork shouldSaveCodebase transcriptFiles -> - runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveCodebase mcodepath transcriptFiles - UpgradeCodebase -> upgradeCodebase mcodepath - Launch isHeadless codebaseServerOpts -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles + Launch isHeadless codebaseServerOpts downloadBase -> do + ((closeCodebase, theCodebase),initRes) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do - PT.putPrettyLn $ P.lines - ["The Unison Codebase UI is running at", P.string $ Server.urlFor Server.UI baseUrl] case isHeadless of Headless -> do - PT.putPrettyLn $ P.lines - ["I've started the codebase API server at" , P.string $ Server.urlFor Server.Api baseUrl] + PT.putPrettyLn $ + P.lines + [ "I've started the Codebase API server at", + P.string $ Server.urlFor Server.Api baseUrl, + "and the Codebase UI at", + P.string $ Server.urlFor Server.UI baseUrl + ] + PT.putPrettyLn $ P.string "Running the codebase manager headless with " <> P.shown GHC.Conc.numCapabilities <> " " @@ -131,52 +147,35 @@ main = do mvar <- newEmptyMVar takeMVar mvar WithCLI -> do - PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager..." - launch currentDir config runtime theCodebase [] (Just baseUrl) + PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." + launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes closeCodebase -upgradeCodebase :: Maybe Codebase.CodebasePath -> IO () -upgradeCodebase mcodepath = - Codebase.getCodebaseDir mcodepath >>= \root -> do - PT.putPrettyLn . P.wrap $ - "I'm upgrading the codebase in " <> P.backticked' (P.string root) "," <> "but it will" - <> "take a while, and may even run out of memory. If you have" - <> "trouble, contact us on #alphatesting and we'll try to help." - Upgrade12.upgradeCodebase root - PT.putPrettyLn . P.wrap - $ P.newline - <> "Try it out and once you're satisfied, you can safely(?) delete the old version from" - <> P.newline - <> P.indentN 2 (P.string $ Codebase.codebasePath (FC.init @IO) root) - <> P.newline - <> "but there's no rush. You can access the old codebase again by passing the" - <> P.backticked "--old-codebase" <> "flag at startup." - -prepareTranscriptDir :: CodebaseFormat -> ShouldForkCodebase -> Maybe FilePath -> IO FilePath -prepareTranscriptDir cbFormat shouldFork mcodepath = do +prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath +prepareTranscriptDir shouldFork mCodePathOption = do tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript") - let cbInit = cbInitFor cbFormat + let cbInit = SC.init case shouldFork of UseFork -> do - getCodebaseOrExit cbFormat mcodepath - path <- Codebase.getCodebaseDir mcodepath - PT.putPrettyLn $ P.lines [ + -- A forked codebase does not need to Create a codebase, because it already exists + getCodebaseOrExit mCodePathOption + path <- Codebase.getCodebaseDir (fmap codebasePathOptionToPath mCodePathOption) + PT.putPrettyLn $ P.lines [ P.wrap "Transcript will be run on a copy of the codebase at: ", "", P.indentN 2 (P.string path) ] - Path.copyDir (Codebase.codebasePath cbInit path) (Codebase.codebasePath cbInit tmp) + Path.copyDir (CodebaseInit.codebasePath cbInit path) (CodebaseInit.codebasePath cbInit tmp) DontFork -> do PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase." - void $ Codebase.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp + void $ CodebaseInit.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp pure tmp runTranscripts' - :: CodebaseFormat - -> Maybe FilePath + :: Maybe FilePath -> FilePath -> NonEmpty String -> IO Bool -runTranscripts' codebaseFormat mcodepath transcriptDir args = do +runTranscripts' mcodepath transcriptDir args = do currentDir <- getCurrentDirectory let (markdownFiles, invalidArgs) = NonEmpty.partition isMarkdown args for_ markdownFiles $ \fileName -> do @@ -189,7 +188,8 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do P.indentN 2 $ P.string err]) Right stanzas -> do configFilePath <- getConfigFilePath mcodepath - (closeCodebase, theCodebase) <- getCodebaseOrExit codebaseFormat $ Just transcriptDir + -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. + ((closeCodebase, theCodebase),_) <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -210,17 +210,16 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do runTranscripts :: UsageRenderer - -> CodebaseFormat -> ShouldForkCodebase -> ShouldSaveCodebase - -> Maybe FilePath + -> Maybe CodebasePathOption -> NonEmpty String -> IO () -runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodepath args = do +runTranscripts renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption args = do progName <- getProgName - transcriptDir <- prepareTranscriptDir cbFormat shouldFork mcodepath + transcriptDir <- prepareTranscriptDir shouldFork mCodePathOption completed <- - runTranscripts' cbFormat (Just transcriptDir) transcriptDir args + runTranscripts' (Just transcriptDir) transcriptDir args case shouldSaveTempCodebase of DontSaveCodebase -> removeDirectoryRecursive transcriptDir SaveCodebase -> @@ -232,7 +231,7 @@ runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodep "I've finished running the transcript(s) in this codebase:", "", P.indentN 2 (P.string transcriptDir), "", P.wrap $ "You can run" - <> P.backticked (P.string progName <> " -codebase " <> P.string transcriptDir) + <> P.backticked (P.string progName <> " --codebase " <> P.string transcriptDir) <> "to do more work with it."]) else do putStrLn (renderUsageInfo $ Just "transcript") @@ -248,18 +247,29 @@ launch -> Codebase.Codebase IO Symbol Ann -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl + -> ShouldDownloadBase + -> InitResult IO Symbol Ann -> IO () -launch dir config runtime codebase inputs serverBaseUrl = - CommandLine.main - dir - defaultBaseLib - initialPath - config - inputs - runtime - codebase - Version.gitDescribe - serverBaseUrl +launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initResult = + let + downloadBase = case defaultBaseLib of + Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS + _ -> Welcome.DontDownloadBase + isNewCodebase = case initResult of + CreatedCodebase{} -> NewlyCreatedCodebase + _ -> PreviouslyCreatedCodebase + + welcome = Welcome.welcome isNewCodebase downloadBase dir Version.gitDescribe + in + CommandLine.main + dir + welcome + initialPath + config + inputs + runtime + codebase + serverBaseUrl isMarkdown :: String -> Bool isMarkdown md = case FP.takeExtension md of @@ -281,73 +291,58 @@ getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseD defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) - --- | load an existing codebase or exit. -getCodebaseOrExit :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebaseOrExit cbFormat mdir = do - let cbInit = cbInitFor cbFormat - dir <- Codebase.getCodebaseDir mdir - Codebase.openCodebase cbInit "main" dir >>= \case - Left _errRequestedVersion -> do +-- (Unison.Codebase.Init.FinalizerAndCodebase IO Symbol Ann, InitResult IO Symbol Ann) +getCodebaseOrExit :: Maybe CodebasePathOption -> IO ((IO (), Codebase.Codebase IO Symbol Ann), InitResult IO Symbol Ann) +getCodebaseOrExit codebasePathOption = do + initOptions <- argsToCodebaseInitOptions codebasePathOption + CodebaseInit.openOrCreateCodebase SC.init "main" initOptions >>= \case + Error dir error -> let - sayNoCodebase = noCodebaseMsg <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir) - suggestUpgrade = suggestUpgradeMessage <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir) - prettyExe = P.text . Text.pack <$> getProgName - prettyDir = P.string <$> canonicalizePath dir - PT.putPrettyLn' =<< case cbFormat of - V1 -> sayNoCodebase - V2 -> FC.openCodebase dir >>= \case - Left {} -> sayNoCodebase - Right {} -> suggestUpgrade - Exit.exitFailure - Right x -> pure x - where - noCodebaseMsg :: _ - noCodebaseMsg executable prettyDir mdir = - let secondLine = - case mdir of - Just dir -> - "Run `" <> executable <> " -codebase " <> dir - <> " init` to create one, then try again!" - Nothing -> - "Run `" <> executable <> " init` to create one there," - <> " then try again;" - <> " or `" - <> executable - <> " -codebase ` to load a codebase from someplace else!" - in P.lines - [ "No codebase exists in " <> prettyDir <> ".", - secondLine - ] - suggestUpgradeMessage exec resolvedDir specifiedDir = - P.lines - ( P.wrap - <$> [ "I looked for a" <> prettyFmt V2 <> " codebase in " <> P.backticked' resolvedDir "," - <> "but found only a" - <> prettyFmt V1 - <> "codebase there.", - "", - "You can use:" - ] - ) - <> P.newline - <> P.bulleted - ( P.wrap - <$> [ P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "upgrade-codebase") - <> "to update it to" - <> P.group (prettyFmt V2 <> ","), - P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "init") - <> "to create a new" - <> prettyFmt V2 - <> "codebase alongside it, or", - P.backticked (P.wrap $ exec <> "-codebase ") - <> "to load a" - <> prettyFmt V2 - <> "codebase from elsewhere." - ] - ) + message = do + pDir <- prettyDir dir + executableName <- P.text . Text.pack <$> getProgName + + case error of + NoCodebaseFoundAtSpecifiedDir -> + pure (P.lines + [ "No codebase exists in " <> pDir <> ".", + "Run `" <> executableName <> " --codebase-create " <> P.string dir <> " to create one, then try again!" + ]) + + FoundV1Codebase -> + pure (P.lines + [ "Found a v1 codebase at " <> pDir <> ".", + "v1 codebases are no longer supported in this version of the UCM.", + "Please download version M2g of the UCM to upgrade." + ]) + CouldntCreateCodebase errMessage -> + pure errMessage + in do + msg <- message + PT.putPrettyLn' msg + Exit.exitFailure + c@(CreatedCodebase dir cb) -> do + pDir <- prettyDir dir + PT.putPrettyLn' "" + PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue pDir + pure (cb, c) + + o@(OpenedCodebase _ cb) -> + pure (cb, o) + + where + prettyDir dir = P.string <$> canonicalizePath dir +argsToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInit.CodebaseInitOptions +argsToCodebaseInitOptions pathOption = + case pathOption of + Just (CreateCodebaseWhenMissing path) -> pure $ Specified (CreateWhenMissing path) + Just (DontCreateCodebaseWhenMissing path) -> pure $ Specified (DontCreateWhenMissing path) + Nothing -> do Home <$> getHomeDirectory - prettyFmt :: IsString s => CodebaseFormat -> P.Pretty s - prettyFmt = \case V1 -> "v1"; V2 -> "v2" +codebasePathOptionToPath :: CodebasePathOption -> FilePath +codebasePathOptionToPath codebasePathOption = + case codebasePathOption of + CreateCodebaseWhenMissing p -> p + DontCreateCodebaseWhenMissing p -> p \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 08749cd1e2..be3ad64b32 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ packages: - codebase2/util-term #compiler-check: match-exact -resolver: lts-17.15 +resolver: lts-18.9 extra-deps: - github: unisonweb/configurator @@ -35,18 +35,8 @@ extra-deps: - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- random-1.2.0 -# remove these when stackage upgrades containers -# (these = containers 0.6.4, text-1.2.4, binary-0.8.8, parsec-3.1.14, Cabal-3.2.1.0) -# see https://github.com/unisonweb/unison/pull/1807#issuecomment-777069869 -- containers-0.6.4.1 -- text-1.2.4.1 -- binary-0.8.8.0 -- parsec-3.1.14.0 -- Cabal-3.2.1.0 - fuzzyfind-3.0.0 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 -- optparse-applicative-0.16.1.0 # We need some features from the most recent revision ghc-options: # All packages diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 6548ac3add..dbe8513350 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -6,42 +6,61 @@ {-# Language PatternSynonyms #-} {-# Language ViewPatterns #-} -module Unison.DataDeclaration where +module Unison.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + DeclOrBuiltin(..), + Modifier(..), + allVars, + asDataDecl, + bindReferences, + constructorNames, + constructors, + constructorType, + constructorTypes, + constructorVars, + declConstructorReferents, + declDependencies, + declFields, + dependencies, + generateRecordAccessors, + unhashComponent, + mkDataDecl', + mkEffectDecl', + typeOfConstructor, + withEffectDeclM, + amap, + updateDependencies, + ) +where import Unison.Prelude -import Control.Lens (_3, over) +import Control.Lens (over, _3) import Control.Monad.State (evalState) - -import Data.Bifunctor (first, second, bimap) -import qualified Unison.Util.Relation as Rel -import Unison.Hash ( Hash ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding ( cycle ) -import Prelude.Extras ( Show1 ) -import qualified Unison.ABT as ABT -import Unison.Hashable ( Accumulate - , Hashable1 - ) -import qualified Unison.Hashable as Hashable -import qualified Unison.Name as Name -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as Reference.Util -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import Unison.Term ( Term ) -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import Unison.Var ( Var ) -import qualified Unison.Var as Var -import Unison.Names3 (Names0) -import qualified Unison.Names3 as Names -import qualified Unison.Pattern as Pattern +import Data.Bifunctor (bimap, first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import qualified Unison.ABT as ABT import qualified Unison.ConstructorType as CT - -type ConstructorId = Term.ConstructorId +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Pattern as Pattern +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import qualified Unison.Referent' as Referent' +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var +import Prelude hiding (cycle) type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) @@ -74,25 +93,13 @@ newtype EffectDeclaration v a = EffectDeclaration { toDataDecl :: DataDeclaration v a } deriving (Eq,Show,Functor) -withEffectDecl - :: (DataDeclaration v a -> DataDeclaration v' a') - -> (EffectDeclaration v a -> EffectDeclaration v' a') -withEffectDecl f e = EffectDeclaration (f . toDataDecl $ e) - withEffectDeclM :: Functor f => (DataDeclaration v a -> f (DataDeclaration v' a')) -> EffectDeclaration v a -> f (EffectDeclaration v' a') withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl -generateConstructorRefs - :: (Reference -> ConstructorId -> Reference) - -> Reference.Id - -> Int - -> [(ConstructorId, Reference)] -generateConstructorRefs hashCtor rid n = - (\i -> (i, hashCtor (Reference.DerivedId rid) i)) <$> [0 .. n] - +-- propose to move this code to some very feature-specific module β€”AI generateRecordAccessors :: (Semigroup a, Var v) => [(v, a)] @@ -148,37 +155,10 @@ generateRecordAccessors fields typename typ = else Term.var ann v | ((v, _), j) <- fields `zip` [0..]] --- Returns references to the constructors, --- along with the terms for those references and their types. -constructorTerms - :: (Reference -> ConstructorId -> Reference) - -> (a -> Reference -> ConstructorId -> Term v a) - -> Reference.Id - -> DataDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -constructorTerms hashCtor f rid dd = - (\((a, _, t), (i, re@(Reference.DerivedId r))) -> (r, f a re i, t)) <$> zip - (constructors' dd) - (generateConstructorRefs hashCtor rid (length $ constructors dd)) - -dataConstructorTerms - :: Ord v - => Reference.Id - -> DataDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -dataConstructorTerms = constructorTerms Term.hashConstructor Term.constructor - -effectConstructorTerms - :: Ord v - => Reference.Id - -> EffectDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -effectConstructorTerms rid ed = - constructorTerms Term.hashRequest Term.request rid $ toDataDecl ed - constructorTypes :: DataDeclaration v a -> [Type v a] constructorTypes = (snd <$>) . constructors +-- what is declFields? β€”AI declFields :: Var v => Decl v a -> Either [Int] [Int] declFields = bimap cf cf . first toDataDecl where @@ -199,12 +179,15 @@ constructorVars dd = fst <$> constructors dd constructorNames :: Var v => DataDeclaration v a -> [Text] constructorNames dd = Var.name <$> constructorVars dd +-- This function is unsound, since the `rid` and the `decl` have to match. +-- It should probably be hashed directly from the Decl, once we have a +-- reliable way of doing that. β€”AI declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] declConstructorReferents rid decl = - [ Referent.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] + [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] where ct = constructorType decl -constructorIds :: DataDeclaration v a -> [Int] +constructorIds :: DataDeclaration v a -> [ConstructorId] constructorIds dd = [0 .. length (constructors dd) - 1] -- | All variables mentioned in the given data declaration. @@ -218,64 +201,28 @@ allVars (DataDeclaration _ _ bound ctors) = Set.unions $ allVars' :: Ord v => Decl v a -> Set v allVars' = allVars . either toDataDecl id -bindNames :: Var v +bindReferences :: Var v => Set v - -> Names0 + -> Map Name.Name Reference -> DataDeclaration v a -> Names.ResolutionResult v a (DataDeclaration v a) -bindNames keepFree names (DataDeclaration m a bound constructors) = do +bindReferences keepFree names (DataDeclaration m a bound constructors) = do constructors <- for constructors $ \(a, v, ty) -> - (a,v,) <$> Type.bindNames keepFree names ty + (a,v,) <$> Type.bindReferences keepFree names ty pure $ DataDeclaration m a bound constructors dependencies :: Ord v => DataDeclaration v a -> Set Reference dependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) -third :: (a -> b) -> (x,y,a) -> (x,y,b) -third f (x,y,a) = (x, y, f a) - --- implementation of dataDeclToNames and effectDeclToNames -toNames0 :: Var v => CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names0 -toNames0 ct typeSymbol (Reference.DerivedId -> r) dd = - -- constructor names - foldMap names (constructorVars dd `zip` [0 ..]) - -- name of the type itself - <> Names.names0 mempty (Rel.singleton (Name.fromVar typeSymbol) r) - where - names (ctor, i) = - Names.names0 (Rel.singleton (Name.fromVar ctor) (Referent.Con r i ct)) mempty - -dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names0 -dataDeclToNames = toNames0 CT.Data - -effectDeclToNames :: Var v => v -> Reference.Id -> EffectDeclaration v a -> Names0 -effectDeclToNames typeSymbol r ed = toNames0 CT.Effect typeSymbol r $ toDataDecl ed - -dataDeclToNames' :: Var v => (v, (Reference.Id, DataDeclaration v a)) -> Names0 -dataDeclToNames' (v,(r,d)) = dataDeclToNames v r d - -effectDeclToNames' :: Var v => (v, (Reference.Id, EffectDeclaration v a)) -> Names0 -effectDeclToNames' (v, (r, d)) = effectDeclToNames v r d - mkEffectDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> EffectDeclaration v a mkEffectDecl' m a b cs = EffectDeclaration (DataDeclaration m a b cs) -mkEffectDecl :: Modifier -> [v] -> [(v, Type v ())] -> EffectDeclaration v () -mkEffectDecl m b cs = mkEffectDecl' m () b $ map (\(v, t) -> ((), v, t)) cs - mkDataDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> DataDeclaration v a mkDataDecl' = DataDeclaration -mkDataDecl :: Modifier -> [v] -> [(v, Type v ())] -> DataDeclaration v () -mkDataDecl m b cs = mkDataDecl' m () b $ map (\(v,t) -> ((),v,t)) cs - -constructorArities :: DataDeclaration v a -> [Int] -constructorArities (DataDeclaration _ _a _bound ctors) = - Type.arity . (\(_,_,t) -> t) <$> ctors - data F a = Type (Type.F a) | LetRec [a] a @@ -283,64 +230,6 @@ data F a | Modified Modifier a deriving (Functor, Foldable, Show, Show1) -instance Hashable1 F where - hash1 hashCycle hash e = - let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `2` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 2 : case e of - Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] - LetRec bindings body -> - let (hashes, hash') = hashCycle bindings - in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] - Constructors cs -> - let (hashes, _) = hashCycle cs - in tag 2 : map hashed hashes - Modified m t -> - [tag 3, Hashable.accumulateToken m, hashed $ hash t] - -instance Hashable.Hashable Modifier where - tokens Structural = [Hashable.Tag 0] - tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] - -{- - type UpDown = Up | Down - - type List a = Nil | Cons a (List a) - - type Ping p = Ping (Pong p) - type Pong p = Pong (Ping p) - - type Foo a f = Foo Int (Bar a) - type Bar a f = Bar Long (Foo a) --} - -hash :: (Eq v, Var v, Ord h, Accumulate h) - => [(v, ABT.Term F v ())] -> [(v, h)] -hash recursiveDecls = zip (fst <$> recursiveDecls) hashes where - hashes = ABT.hash <$> toLetRec recursiveDecls - -toLetRec :: Ord v => [(v, ABT.Term F v ())] -> [ABT.Term F v ()] -toLetRec decls = do1 <$> vs - where - (vs, decls') = unzip decls - -- we duplicate this letrec once (`do1`) - -- for each of the mutually recursive types - do1 v = ABT.cycle (ABT.absChain vs . ABT.tm $ LetRec decls' (ABT.var v)) - -unsafeUnwrapType :: (Var v) => ABT.Term F v a -> Type v a -unsafeUnwrapType typ = ABT.transform f typ - where f (Type t) = t - f _ = error $ "Tried to unwrap a type that wasn't a type: " ++ show typ - -toABT :: Var v => DataDeclaration v () -> ABT.Term F v () -toABT dd = ABT.tm $ Modified (modifier dd) dd' - where - dd' = ABT.absChain (bound dd) $ ABT.cycle - (ABT.absChain - (fst <$> constructors dd) - (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) - updateDependencies :: Ord v => Map Reference Reference -> Decl v a -> Decl v a updateDependencies typeUpdates decl = back $ dataDecl { constructors' = over _3 (Type.updateDependencies typeUpdates) @@ -375,43 +264,6 @@ unhashComponent m in second unhash2 <$> m' --- Implementation detail of `hashDecls`, works with unannotated data decls -hashDecls0 :: (Eq v, Var v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] -hashDecls0 decls = - let abts = toABT <$> decls - ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) - cs = Reference.Util.hashComponents ref abts - in [ (v, r) | (v, (r, _)) <- Map.toList cs ] - --- | compute the hashes of these user defined types and update any free vars --- corresponding to these decls with the resulting hashes --- --- data List a = Nil | Cons a (List a) --- becomes something like --- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) --- --- NOTE: technical limitation, this implementation gives diff results if ctors --- have the same FQN as one of the types. TODO: assert this and bomb if not --- satisfied, or else do local mangling and unmangling to ensure this doesn't --- affect the hash. -hashDecls - :: (Eq v, Var v) - => Map v (DataDeclaration v a) - -> Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] -hashDecls decls = do - -- todo: make sure all other external references are resolved before calling this - let varToRef = hashDecls0 (void <$> decls) - varToRef' = second Reference.DerivedId <$> varToRef - decls' = bindTypes <$> decls - bindTypes dd = dd { constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd } - typeNames0 = Names.names0 mempty - $ Rel.fromList (first Name.fromVar <$> varToRef') - -- normalize the order of the constructors based on a hash of their types - sortCtors dd = dd { constructors' = sortOn hash3 $ constructors' dd } - hash3 (_, _, typ) = ABT.hash typ :: Hash - decls' <- fmap sortCtors <$> traverse (bindNames mempty typeNames0) decls' - pure [ (v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls'] ] - amap :: (a -> a2) -> Decl v a -> Decl v a2 amap f (Left e) = Left (f <$> e) amap f (Right d) = Right (f <$> d) diff --git a/unison-core/src/Unison/DataDeclaration/ConstructorId.hs b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs new file mode 100644 index 0000000000..0de60aed08 --- /dev/null +++ b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.DataDeclaration.ConstructorId (ConstructorId) where + +type ConstructorId = Int diff --git a/unison-core/src/Unison/DataDeclaration/Names.hs b/unison-core/src/Unison/DataDeclaration/Names.hs new file mode 100644 index 0000000000..64bf046da9 --- /dev/null +++ b/unison-core/src/Unison/DataDeclaration/Names.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.DataDeclaration.Names (bindNames, dataDeclToNames', effectDeclToNames') where + +import Unison.Prelude + +import Unison.DataDeclaration (DataDeclaration (DataDeclaration), EffectDeclaration) +import qualified Unison.DataDeclaration as DD + + +import qualified Unison.Util.Relation as Rel +import Prelude hiding ( cycle ) +import qualified Unison.Name as Name +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import qualified Unison.Type.Names as Type.Names +import Unison.Var ( Var ) +import Unison.Names3 (Names0) +import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.ConstructorType as CT + +-- implementation of dataDeclToNames and effectDeclToNames +toNames0 :: Var v => CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names0 +toNames0 ct typeSymbol (Reference.DerivedId -> r) dd = + -- constructor names + foldMap names (DD.constructorVars dd `zip` [0 ..]) + -- name of the type itself + <> Names.names0 mempty (Rel.singleton (Name.fromVar typeSymbol) r) + where + names (ctor, i) = + Names.names0 (Rel.singleton (Name.fromVar ctor) (Referent.Con r i ct)) mempty + +dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names0 +dataDeclToNames = toNames0 CT.Data + +effectDeclToNames :: Var v => v -> Reference.Id -> EffectDeclaration v a -> Names0 +effectDeclToNames typeSymbol r ed = toNames0 CT.Effect typeSymbol r $ DD.toDataDecl ed + +dataDeclToNames' :: Var v => (v, (Reference.Id, DataDeclaration v a)) -> Names0 +dataDeclToNames' (v, (r,d)) = dataDeclToNames v r d + +effectDeclToNames' :: Var v => (v, (Reference.Id, EffectDeclaration v a)) -> Names0 +effectDeclToNames' (v, (r, d)) = effectDeclToNames v r d + +bindNames :: Var v + => Set v + -> Names0 + -> DataDeclaration v a + -> Names.ResolutionResult v a (DataDeclaration v a) +bindNames keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.Names.bindNames keepFree names ty + pure $ DataDeclaration m a bound constructors + diff --git a/unison-core/src/Unison/HashQualified.hs b/unison-core/src/Unison/HashQualified.hs index 8718fedfdf..73c3a9084f 100644 --- a/unison-core/src/Unison/HashQualified.hs +++ b/unison-core/src/Unison/HashQualified.hs @@ -13,7 +13,7 @@ import Unison.Name ( Name, Convert, Parse ) import qualified Unison.Name as Name import Unison.Reference ( Reference ) import qualified Unison.Reference as Reference -import Unison.Referent ( Referent ) +import Unison.Referent ( Referent, ConstructorId ) import qualified Unison.Referent as Referent import Unison.ShortHash ( ShortHash ) import qualified Unison.ShortHash as SH @@ -124,7 +124,7 @@ fromReferent = HashOnly . Referent.toShortHash fromReference :: Reference -> HashQualified Name fromReference = HashOnly . Reference.toShortHash -fromPattern :: Reference -> Int -> HashQualified Name +fromPattern :: Reference -> ConstructorId -> HashQualified Name fromPattern r cid = HashOnly $ Referent.patternShortHash r cid fromName :: n -> HashQualified n @@ -175,6 +175,7 @@ instance (Eq n, Name.Alphabetical n) => Ord (HashQualified n) where instance Convert n n2 => Convert (HashQualified n) (HashQualified n2) where convert = fmap Name.convert + instance Convert n (HashQualified n) where convert = NameOnly diff --git a/unison-core/src/Unison/LabeledDependency.hs b/unison-core/src/Unison/LabeledDependency.hs index 13f5a858a1..289d283fa8 100644 --- a/unison-core/src/Unison/LabeledDependency.hs +++ b/unison-core/src/Unison/LabeledDependency.hs @@ -19,7 +19,7 @@ import Unison.Prelude hiding (fold) import Unison.ConstructorType (ConstructorType(Data, Effect)) import Unison.Reference (Reference(DerivedId), Id) -import Unison.Referent (Referent, pattern Ref, pattern Con, Referent'(Ref', Con')) +import Unison.Referent (Referent, pattern Ref, pattern Con, ConstructorId) import qualified Data.Set as Set -- dumb constructor name is private @@ -28,8 +28,8 @@ newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Sho derivedType, derivedTerm :: Id -> LabeledDependency typeRef, termRef :: Reference -> LabeledDependency referent :: Referent -> LabeledDependency -dataConstructor :: Reference -> Int -> LabeledDependency -effectConstructor :: Reference -> Int -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency derivedType = X . Left . DerivedId derivedTerm = X . Right . Ref . DerivedId @@ -52,5 +52,5 @@ partition = partitionEithers . map (\(X e) -> e) . toList toReference :: LabeledDependency -> Either Reference Reference toReference = \case X (Left r) -> Left r - X (Right (Ref' r)) -> Right r - X (Right (Con' r _ _)) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r diff --git a/unison-core/src/Unison/NameSegment.hs b/unison-core/src/Unison/NameSegment.hs index 8f903d8995..42b1bf0fc9 100644 --- a/unison-core/src/Unison/NameSegment.hs +++ b/unison-core/src/Unison/NameSegment.hs @@ -6,7 +6,6 @@ import Unison.Prelude import qualified Data.Text as Text import qualified Unison.Hashable as H - import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical) -- Represents the parts of a name between the `.`s diff --git a/unison-core/src/Unison/Names/ResolutionResult.hs b/unison-core/src/Unison/Names/ResolutionResult.hs new file mode 100644 index 0000000000..9968a26463 --- /dev/null +++ b/unison-core/src/Unison/Names/ResolutionResult.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Names.ResolutionResult where + +import Unison.Prelude +import Unison.Reference as Reference ( Reference ) +import Unison.Referent as Referent ( Referent ) + +data ResolutionFailure v a + = TermResolutionFailure v a (Set Referent) + | TypeResolutionFailure v a (Set Reference) + deriving (Eq,Ord,Show) + +type ResolutionResult v a r = Either (Seq (ResolutionFailure v a)) r diff --git a/unison-core/src/Unison/Names3.hs b/unison-core/src/Unison/Names3.hs index d91a4776a6..246e82d0bf 100644 --- a/unison-core/src/Unison/Names3.hs +++ b/unison-core/src/Unison/Names3.hs @@ -8,8 +8,7 @@ module Unison.Names3 where import Unison.Prelude import Control.Lens (view, _4) -import Data.List (sort) -import Data.List.Extra (nubOrd) +import Data.List.Extra (nubOrd, sort) import Unison.HashQualified (HashQualified) import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' @@ -29,15 +28,9 @@ import qualified Unison.ConstructorType as CT data Names = Names { currentNames :: Names0, oldNames :: Names0 } deriving Show type Names0 = Unison.Names2.Names0 +pattern Names0 :: Relation n Referent -> Relation n Reference -> Names.Names' n pattern Names0 terms types = Unison.Names2.Names terms types -data ResolutionFailure v a - = TermResolutionFailure v a (Set Referent) - | TypeResolutionFailure v a (Set Reference) - deriving (Eq,Ord,Show) - -type ResolutionResult v a r = Either (Seq (ResolutionFailure v a)) r - filterTypes :: (Name -> Bool) -> Names0 -> Names0 filterTypes = Unison.Names2.filterTypes @@ -318,13 +311,13 @@ expandWildcardImport prefix ns = pure (suffix, full) -- Deletes from the `n0 : Names0` any definitions whose names --- share a suffix with a name in `ns`. Does so using logarithmic --- time lookups, traversing only `ns`. +-- are in `ns`. Does so using logarithmic time lookups, +-- traversing only `ns`. -- -- See usage in `FileParser` for handling precendence of symbol -- resolution where local names are preferred to codebase names. -shadowSuffixedTerms0 :: [Name] -> Names0 -> Names0 -shadowSuffixedTerms0 ns n0 = names0 terms' (types0 n0) +shadowTerms0 :: [Name] -> Names0 -> Names0 +shadowTerms0 ns n0 = names0 terms' (types0 n0) where - shadowedBy name = Name.searchBySuffix name (terms0 n0) - terms' = R.subtractRan (foldMap shadowedBy ns) (terms0 n0) + terms' = foldl' go (terms0 n0) ns + go ts name = R.deleteDom name ts diff --git a/unison-core/src/Unison/Pattern.hs b/unison-core/src/Unison/Pattern.hs index ee133c1645..909288615d 100644 --- a/unison-core/src/Unison/Pattern.hs +++ b/unison-core/src/Unison/Pattern.hs @@ -4,20 +4,19 @@ module Unison.Pattern where import Unison.Prelude +import qualified Data.Foldable as Foldable hiding (foldMap') import Data.List (intercalate) -import Data.Foldable as Foldable hiding (foldMap') -import Unison.Reference (Reference) -import Unison.Referent (Referent) import qualified Data.Map as Map -import qualified Unison.Referent as Referent +import qualified Data.Set as Set import qualified Unison.ConstructorType as CT +import Unison.DataDeclaration.ConstructorId (ConstructorId) import qualified Unison.Hashable as H -import qualified Unison.Type as Type -import qualified Data.Set as Set -import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) - -type ConstructorId = Int +import qualified Unison.LabeledDependency as LD +import Unison.Reference (Reference) +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent +import qualified Unison.Type as Type data Pattern loc = Unbound loc @@ -28,10 +27,10 @@ data Pattern loc | Float loc !Double | Text loc !Text | Char loc !Char - | Constructor loc !Reference !Int [Pattern loc] + | Constructor loc !Reference !ConstructorId [Pattern loc] | As loc (Pattern loc) | EffectPure loc (Pattern loc) - | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | EffectBind loc !Reference !ConstructorId [Pattern loc] (Pattern loc) | SequenceLiteral loc [Pattern loc] | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) deriving (Ord,Generic,Functor,Foldable,Traversable) @@ -126,6 +125,7 @@ instance H.Hashable (Pattern p) where instance Eq (Pattern loc) where Unbound _ == Unbound _ = True Var _ == Var _ = True + Char _ c == Char _ d = c == d Boolean _ b == Boolean _ b2 = b == b2 Int _ n == Int _ m = n == m Nat _ n == Nat _ m = n == m diff --git a/unison-core/src/Unison/PatternCompat.hs b/unison-core/src/Unison/PatternCompat.hs deleted file mode 100644 index 31ee1c532d..0000000000 --- a/unison-core/src/Unison/PatternCompat.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# Language PatternSynonyms #-} - -module Unison.PatternCompat where - -import qualified Unison.Pattern as P - -type Pattern = P.Pattern () - -{-# COMPLETE Unbound, Var, Boolean, Int, Nat, Float, Text, Char, Constructor, As, EffectPure, EffectBind, SequenceLiteral, SequenceOp #-} - -pattern Unbound = P.Unbound () -pattern Var = P.Var () -pattern Boolean b = P.Boolean () b -pattern Int n = P.Int () n -pattern Nat n = P.Nat () n -pattern Float n = P.Float () n -pattern Text t = P.Text () t -pattern Char c = P.Char () c -pattern Constructor r cid ps = P.Constructor () r cid ps -pattern As p = P.As () p -pattern EffectPure p = P.EffectPure () p -pattern EffectBind r cid ps k = P.EffectBind () r cid ps k -pattern SequenceLiteral ps = P.SequenceLiteral () ps -pattern SequenceOp ph op pt = P.SequenceOp () ph op pt - -{-# COMPLETE Snoc, Cons, Concat #-} -type SeqOp = P.SeqOp -pattern Snoc = P.Snoc -pattern Cons = P.Cons -pattern Concat = P.Concat diff --git a/unison-core/src/Unison/Reference/Util.hs b/unison-core/src/Unison/Reference/Util.hs index 2d63d2d6b1..b08f41c520 100644 --- a/unison-core/src/Unison/Reference/Util.hs +++ b/unison-core/src/Unison/Reference/Util.hs @@ -2,7 +2,6 @@ module Unison.Reference.Util where import Unison.Prelude -import Unison.Reference import qualified Unison.Reference as Reference import Unison.Hashable (Hashable1) import Unison.ABT (Var) @@ -16,7 +15,7 @@ hashComponents :: -> Map v (Reference.Id, ABT.Term f v a) hashComponents embedRef tms = Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] - where cs = components $ ABT.hashComponents ref tms - ref h i n = embedRef (Id h i n) + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) diff --git a/unison-core/src/Unison/Referent'.hs b/unison-core/src/Unison/Referent'.hs new file mode 100644 index 0000000000..0d2689956f --- /dev/null +++ b/unison-core/src/Unison/Referent'.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Referent' where + +import Unison.ConstructorType (ConstructorType) +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Hashable (Hashable (tokens)) +import qualified Unison.Hashable as H +import Unison.Prelude (Word64) + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. + +-- | When @Ref'@ then @r@ represents a term. +-- +-- When @Con'@ then @r@ is a type declaration. +data Referent' r = Ref' r | Con' r ConstructorId ConstructorType + deriving (Show, Ord, Eq, Functor) + +isConstructor :: Referent' r -> Bool +isConstructor Con' {} = True +isConstructor _ = False + +toTermReference :: Referent' r -> Maybe r +toTermReference = \case + Ref' r -> Just r + _ -> Nothing + +toReference' :: Referent' r -> r +toReference' = \case + Ref' r -> r + Con' r _i _t -> r + +toTypeReference :: Referent' r -> Maybe r +toTypeReference = \case + Con' r _i _t -> Just r + _ -> Nothing + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct + +instance Hashable r => Hashable (Referent' r) where + tokens (Ref' r) = [H.Tag 0] ++ H.tokens r + tokens (Con' r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt \ No newline at end of file diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index 77801af37d..639a423635 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -1,21 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -module Unison.Referent where - -import Unison.Prelude - -import qualified Data.Char as Char -import qualified Data.Text as Text -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H -import Unison.Reference (Reference) -import qualified Unison.Reference as R -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH - +module Unison.Referent + ( Referent, + pattern Ref, + pattern Con, + ConstructorId, + Id, + pattern RefId, + pattern ConId, + fold, + toReference, + fromText, + + -- * ShortHash helpers + isPrefixOf, + toShortHash, + toText, + toString, + patternShortHash, + ) +where + +import qualified Data.Char as Char +import qualified Data.Text as Text import Unison.ConstructorType (ConstructorType) import qualified Unison.ConstructorType as CT +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Prelude hiding (fold) +import Unison.Reference (Reference) +import qualified Unison.Reference as R +import Unison.Referent' (Referent' (..), toReference') +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH -- | Specifies a term. -- @@ -24,23 +41,25 @@ import qualified Unison.ConstructorType as CT -- Slightly odd naming. This is the "referent of term name in the codebase", -- rather than the target of a Reference. type Referent = Referent' Reference + pattern Ref :: Reference -> Referent pattern Ref r = Ref' r -pattern Con :: Reference -> Int -> ConstructorType -> Referent + +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent pattern Con r i t = Con' r i t + {-# COMPLETE Ref, Con #-} --- | Cannot be a builtin. +-- | By definition, cannot be a builtin. type Id = Referent' R.Id --- | When @Ref'@ then @r@ represents a term. --- --- When @Con'@ then @r@ is a type declaration. -data Referent' r = Ref' r | Con' r Int ConstructorType - deriving (Show, Ord, Eq, Functor) +pattern RefId :: R.Id -> Unison.Referent.Id +pattern RefId r = Ref' r -type Pos = Word64 -type Size = Word64 +pattern ConId :: R.Id -> ConstructorId -> ConstructorType -> Unison.Referent.Id +pattern ConId r i t = Con' r i t + +{-# COMPLETE RefId, ConId #-} -- referentToTerm moved to Term.fromReferent -- termToReferent moved to Term.toReferent @@ -51,16 +70,10 @@ toShortHash = \case Ref r -> R.toShortHash r Con r i _ -> patternShortHash r i -toShortHashId :: Id -> ShortHash -toShortHashId = toShortHash . fromId - -- also used by HashQualified.fromPattern patternShortHash :: Reference -> Int -> ShortHash patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } -showShort :: Int -> Referent -> Text -showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash - toText :: Referent -> Text toText = \case Ref r -> R.toText r @@ -76,37 +89,12 @@ pattern DataCtor = "d" toString :: Referent -> String toString = Text.unpack . toText -isConstructor :: Referent -> Bool -isConstructor Con{} = True -isConstructor _ = False - -toTermReference :: Referent -> Maybe Reference -toTermReference = \case - Ref r -> Just r - _ -> Nothing - toReference :: Referent -> Reference toReference = toReference' -toReference' :: Referent' r -> r -toReference' = \case - Ref' r -> r - Con' r _i _t -> r - -fromId :: Id -> Referent -fromId = fmap R.DerivedId - -toTypeReference :: Referent -> Maybe Reference -toTypeReference = \case - Con r _i _t -> Just r - _ -> Nothing - isPrefixOf :: ShortHash -> Referent -> Bool isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) -unsafeFromText :: Text -> Referent -unsafeFromText = fromMaybe (error "invalid referent") . fromText - -- #abc[.xy][#cid] fromText :: Text -> Maybe Referent fromText t = either (const Nothing) Just $ @@ -135,7 +123,3 @@ fold :: (r -> a) -> (r -> Int -> ConstructorType -> a) -> Referent' r -> a fold fr fc = \case Ref' r -> fr r Con' r i ct -> fc r i ct - -instance Hashable Referent where - tokens (Ref r) = [H.Tag 0] ++ H.tokens r - tokens (Con r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 325ac44132..1e59c44b5e 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -24,17 +24,14 @@ import Prelude.Extras (Eq1(..), Show1(..)) import Text.Show import qualified Unison.ABT as ABT import qualified Unison.Blank as B -import qualified Unison.Hash as Hash -import Unison.Hashable (Hashable1, accumulateToken) -import qualified Unison.Hashable as Hashable import Unison.Names3 ( Names0 ) import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference, pattern Builtin) import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as ReferenceUtil -import Unison.Referent (Referent) +import Unison.Referent (Referent, ConstructorId) import qualified Unison.Referent as Referent import Unison.Type (Type) import qualified Unison.Type as Type @@ -42,15 +39,12 @@ import qualified Unison.ConstructorType as CT import Unison.Util.List (multimap, validate) import Unison.Var (Var) import qualified Unison.Var as Var -import Unsafe.Coerce -import Unison.Symbol (Symbol) +import qualified Unison.Var.RefNamed as Var +import Unsafe.Coerce (unsafeCoerce) import qualified Unison.Name as Name import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) --- This gets reexported; should maybe live somewhere other than Pattern, though. -type ConstructorId = Pattern.ConstructorId - data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) @@ -121,8 +115,6 @@ bindNames -> Names0 -> Term v a -> Names.ResolutionResult v a (Term v a) --- bindNames keepFreeTerms _ _ | trace "Keep free terms:" False --- || traceShow keepFreeTerms False = undefined bindNames keepFreeTerms ns0 e = do let freeTmVars = [ (v,a) | (v,a) <- ABT.freeVarOccurrences keepFreeTerms e ] -- !_ = trace "bindNames.free term vars: " () @@ -149,7 +141,8 @@ bindNames keepFreeTerms ns0 e = do -- lookup. Any terms not found in the `Names0` are kept free. bindSomeNames :: forall v a . Var v - => Names0 + => Set v + -> Names0 -> Term v a -> Names.ResolutionResult v a (Term v a) -- bindSomeNames ns e | trace "Term.bindSome" False @@ -161,7 +154,7 @@ bindSomeNames -- || traceShow (freeVars e) False -- || traceShow e False -- = undefined -bindSomeNames ns e = bindNames varsToTDNR ns e where +bindSomeNames avoid ns e = bindNames (avoid <> varsToTDNR) ns e where -- `Term.bindNames` takes a set of variables that are not substituted. -- These should be the variables that will be subject to TDNR, which -- we compute as the set of variables whose names cannot be found in `ns`. @@ -445,7 +438,6 @@ unDelay tm = case ABT.out tm of | Set.notMember v (ABT.freeVars body) -> Just body _ -> Nothing - pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) @@ -1001,31 +993,6 @@ unhashComponent m = let go e = e in second unhash1 <$> m' -hashComponents - :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) -hashComponents = ReferenceUtil.hashComponents $ refId () - -hashClosedTerm :: Var v => Term v a -> Reference.Id -hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 - --- The hash for a constructor -hashConstructor' - :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference -hashConstructor' f r cid = - let --- this is a bit circuitous, but defining everything in terms of hashComponents --- ensure the hashing is always done in the same way - m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) - in case toList m of - [(r, _)] -> Reference.DerivedId r - _ -> error "unpossible" - -hashConstructor :: Reference -> ConstructorId -> Reference -hashConstructor = hashConstructor' $ constructor () - -hashRequest :: Reference -> ConstructorId -> Reference -hashRequest = hashConstructor' $ request () - fromReferent :: Ord v => a -> Referent @@ -1036,76 +1003,6 @@ fromReferent a = \case CT.Data -> constructor a r i CT.Effect -> request a r i -instance Var v => Hashable1 (F v a p) where - hash1 hashCycle hash e - = let (tag, hashed, varint) = - (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) - in - case e of - -- So long as `Reference.Derived` ctors are created using the same - -- hashing function as is used here, this case ensures that references - -- are 'transparent' wrt hash and hashing is unaffected by whether - -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash - -- the same. - Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) - Ref (Reference.Derived h i n) -> Hashable.accumulate - [ tag 1 - , hashed $ Hashable.fromBytes (Hash.toBytes h) - , Hashable.Nat i - , Hashable.Nat n - ] - -- Note: start each layer with leading `1` byte, to avoid collisions - -- with types, which start each layer with leading `0`. - -- See `Hashable1 Type.F` - _ -> - Hashable.accumulate - $ tag 1 - : case e of - Nat i -> [tag 64, accumulateToken i] - Int i -> [tag 65, accumulateToken i] - Float n -> [tag 66, Hashable.Double n] - Boolean b -> [tag 67, accumulateToken b] - Text t -> [tag 68, accumulateToken t] - Char c -> [tag 69, accumulateToken c] - Blank b -> tag 1 : case b of - B.Blank -> [tag 0] - B.Recorded (B.Placeholder _ s) -> - [tag 1, Hashable.Text (Text.pack s)] - B.Recorded (B.Resolve _ s) -> - [tag 2, Hashable.Text (Text.pack s)] - Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] - Ref Reference.Derived {} -> - error "handled above, but GHC can't figure this out" - App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] - Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] - List as -> tag 5 : varint (Sequence.length as) : map - (hashed . hash) - (toList as) - Lam a -> [tag 6, hashed (hash a)] - -- note: we use `hashCycle` to ensure result is independent of - -- let binding order - LetRec _ as a -> case hashCycle as of - (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs - -- here, order is significant, so don't use hashCycle - Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] - If b t f -> - [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] - Request r n -> [tag 10, accumulateToken r, varint n] - Constructor r n -> [tag 12, accumulateToken r, varint n] - Match e branches -> - tag 13 : hashed (hash e) : concatMap h branches - where - h (MatchCase pat guard branch) = concat - [ [accumulateToken pat] - , toList (hashed . hash <$> guard) - , [hashed (hash branch)] - ] - Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] - And x y -> [tag 16, hashed $ hash x, hashed $ hash y] - Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] - TermLink r -> [tag 18, accumulateToken r] - TypeLink r -> [tag 19, accumulateToken r] - -- mostly boring serialization code below ... instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 6e8862f553..899eb20e6b 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -17,16 +17,13 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) import qualified Unison.ABT as ABT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable import qualified Unison.Kind as K import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as ReferenceUtil import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Settings as Settings -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name import qualified Unison.Util.List as List @@ -61,18 +58,17 @@ bindExternal :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] -bindNames +bindReferences :: Var v => Set v - -> Names.Names0 + -> Map Name.Name Reference -> Type v a -> Names.ResolutionResult v a (Type v a) -bindNames keepFree ns0 t = let - ns = Names.Names ns0 mempty +bindReferences keepFree ns t = let fvs = ABT.freeVarOccurrences keepFree t - rs = [(v, a, Names.lookupHQType (Name.convert $ Name.fromVar v) ns) | (v,a) <- fvs ] - ok (v, a, rs) = if Set.size rs == 1 then pure (v, Set.findMin rs) - else Left (pure (Names.TypeResolutionFailure v a rs)) + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) in List.validate ok rs <&> \es -> bindExternal es t newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq @@ -186,9 +182,6 @@ isArrow _ = False -- some smart constructors ---vectorOf :: Ord v => a -> Type v a -> Type v ---vectorOf a t = vector `app` t - ref :: Ord v => a -> Reference -> Type v a ref a = ABT.tm' a . Ref @@ -204,9 +197,6 @@ typeLink a = ABT.tm' a . Ref $ typeLinkRef derivedBase32Hex :: Ord v => Reference -> a -> Type v a derivedBase32Hex r a = ref a r --- derivedBase58' :: Text -> Reference --- derivedBase58' base58 = Reference.derivedBase58 base58 0 1 - intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference intRef = Reference.Builtin "Int" natRef = Reference.Builtin "Nat" @@ -227,6 +217,10 @@ filePathRef = Reference.Builtin "FilePath" threadIdRef = Reference.Builtin "ThreadId" socketRef = Reference.Builtin "Socket" +scopeRef, refRef :: Reference +scopeRef = Reference.Builtin "Scope" +refRef = Reference.Builtin "Ref" + mvarRef, tvarRef :: Reference mvarRef = Reference.Builtin "MVar" tvarRef = Reference.Builtin "TVar" @@ -298,6 +292,12 @@ threadId a = ref a threadIdRef builtinIO :: Ord v => a -> Type v a builtinIO a = ref a builtinIORef +scopeType :: Ord v => a -> Type v a +scopeType a = ref a scopeRef + +refType :: Ord v => a -> Type v a +refType a = ref a refRef + socket :: Ord v => a -> Type v a socket a = ref a socketRef @@ -669,43 +669,8 @@ cleanup :: Var v => Type v a -> Type v a cleanup t | not Settings.cleanupTypes = t cleanup t = cleanupVars1 . cleanupAbilityLists $ t -toReference :: (ABT.Var v, Show v) => Type v a -> Reference -toReference (Ref' r) = r --- a bit of normalization - any unused type parameters aren't part of the hash -toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body -toReference t = Reference.Derived (ABT.hash t) 0 1 - -toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference -toReferenceMentions ty = - let (vs, _) = unforall' ty - gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty - in Set.fromList $ toReference . gen <$> ABT.subterms ty - -hashComponents - :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) -hashComponents = ReferenceUtil.hashComponents $ refId () - -instance Hashable1 F where - hash1 hashCycle hash e = - let - (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `0` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 0 : case e of - Ref r -> [tag 0, Hashable.accumulateToken r] - Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] - App a b -> [tag 2, hashed (hash a), hashed (hash b) ] - Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] - -- Example: - -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as - -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from - -- c) {Remote, Abort} (() -> {Abort} ()) - Effects es -> let - (hs, _) = hashCycle es - in tag 4 : map hashed hs - Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] - Forall a -> [tag 6, hashed (hash a)] - IntroOuter a -> [tag 7, hashed (hash a)] +builtinAbilities :: Set Reference +builtinAbilities = Set.fromList [builtinIORef, stmRef] instance Show a => Show (F a) where showsPrec = go where diff --git a/unison-core/src/Unison/Type/Names.hs b/unison-core/src/Unison/Type/Names.hs new file mode 100644 index 0000000000..2a3936d443 --- /dev/null +++ b/unison-core/src/Unison/Type/Names.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Type.Names where + +import Unison.Prelude + +import Unison.Type +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import Unison.Var (Var) +import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +bindNames + :: Var v + => Set v + -> Names.Names0 + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns0 t = let + ns = Names.Names ns0 mempty + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Names.lookupHQType (Name.convert $ Name.fromVar v) ns) | (v,a) <- fvs ] + ok (v, a, rs) = if Set.size rs == 1 then pure (v, Set.findMin rs) + else Left (pure (Names.TypeResolutionFailure v a rs)) + in List.validate ok rs <&> \es -> bindExternal es t diff --git a/unison-core/src/Unison/Util/Relation.hs b/unison-core/src/Unison/Util/Relation.hs index eb6e5f3838..0c03906447 100644 --- a/unison-core/src/Unison/Util/Relation.hs +++ b/unison-core/src/Unison/Util/Relation.hs @@ -9,7 +9,7 @@ import qualified Data.List as List import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Map as Map -import qualified Data.Map.Internal as Map +import qualified Data.Map.Internal as Map import qualified Unison.Hashable as H import qualified Control.Monad as Monad diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index f99c297ac6..d493cfef2b 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -6,15 +6,13 @@ module Unison.Var where import Unison.Prelude -import Data.Char (toLower, isLower) +import Data.Char (isLower, toLower) import Data.Text (pack) import qualified Data.Text as Text import qualified Unison.ABT as ABT import qualified Unison.NameSegment as Name - import Unison.Util.Monoid (intercalateMap) -import Unison.Reference (Reference) -import qualified Unison.Reference as R +import Unison.WatchKind (WatchKind, pattern TestWatch) -- | A class for variables. Variables may have auxiliary information which -- may not form part of their identity according to `Eq` / `Ord`. Laws: @@ -34,10 +32,6 @@ freshIn = ABT.freshIn named :: Var v => Text -> v named n = typed (User n) --- | Variable whose name is derived from the given reference. -refNamed :: Var v => Reference -> v -refNamed ref = named ("ℍ" <> R.toText ref) - rawName :: Type -> Text rawName typ = case typ of User n -> n @@ -120,11 +114,6 @@ data Type | Irrelevant deriving (Eq,Ord,Show) -type WatchKind = String - -pattern RegularWatch = "" -pattern TestWatch = "test" - data InferenceType = Ability | Input | Output | PatternPureE | PatternPureV | diff --git a/unison-core/src/Unison/Var/RefNamed.hs b/unison-core/src/Unison/Var/RefNamed.hs new file mode 100644 index 0000000000..446359b20a --- /dev/null +++ b/unison-core/src/Unison/Var/RefNamed.hs @@ -0,0 +1,13 @@ +{-# Language OverloadedStrings #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} + +module Unison.Var.RefNamed where + +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Var (Var) +import qualified Unison.Var as Var + +refNamed :: Var v => Reference -> v +refNamed ref = Var.named ("ℍ" <> Reference.toText ref) diff --git a/unison-core/src/Unison/WatchKind.hs b/unison-core/src/Unison/WatchKind.hs new file mode 100644 index 0000000000..dccceedb88 --- /dev/null +++ b/unison-core/src/Unison/WatchKind.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.WatchKind where + +type WatchKind = String + +pattern RegularWatch = "" +pattern TestWatch = "test" diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 1b4f4d0b08..5b2c5e5958 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: cef34d9302306093bb4280d9edb3ef4819cb15687e8542dfd977dd83b72ecf13 +-- hash: 3dc00080efb41dcfb41dd8f03bea8ab3e2550a41a92fe1962b9210b52393ce88 name: unison-core1 version: 0.0.0 @@ -30,6 +30,8 @@ library Unison.Blank Unison.ConstructorType Unison.DataDeclaration + Unison.DataDeclaration.ConstructorId + Unison.DataDeclaration.Names Unison.Hash Unison.Hashable Unison.HashQualified @@ -37,21 +39,23 @@ library Unison.Kind Unison.LabeledDependency Unison.Name + Unison.Names.ResolutionResult Unison.Names2 Unison.Names3 Unison.NameSegment Unison.Paths Unison.Pattern - Unison.PatternCompat Unison.Prelude Unison.Reference Unison.Reference.Util Unison.Referent + Unison.Referent' Unison.Settings Unison.ShortHash Unison.Symbol Unison.Term Unison.Type + Unison.Type.Names Unison.Util.Alphabetical Unison.Util.Components Unison.Util.List @@ -61,6 +65,8 @@ library Unison.Util.Relation4 Unison.Util.Set Unison.Var + Unison.Var.RefNamed + Unison.WatchKind other-modules: Paths_unison_core1 hs-source-dirs: diff --git a/unison-src/Base.u b/unison-src/Base.u index a724a43300..98ca0138e8 100644 --- a/unison-src/Base.u +++ b/unison-src/Base.u @@ -154,7 +154,7 @@ List.diagonal = -- -- Use binary search to do lookups and find insertion points -- -- This relies on the underlying sequence having efficient -- -- slicing and concatenation -type Map k v = Map [k] [v] +structural type Map k v = Map [k] [v] -- use Map Map @@ -314,7 +314,7 @@ Multimap.insert k v m = match Map.lookup k m with Multimap.lookup : k -> Map k [v] -> [v] Multimap.lookup k m = Optional.orDefault [] (Map.lookup k m) -type Set a = Set (Map a ()) +structural type Set a = Set (Map a ()) Set.empty : Set k Set.empty = Set Map.empty @@ -346,7 +346,7 @@ Set.size s = Map.size (underlying s) Set.intersect : Set k -> Set k -> Set k Set.intersect s1 s2 = Set (Map.intersect (underlying s1) (underlying s2)) -type Heap k v = Heap Nat k v [Heap k v] +structural type Heap k v = Heap Nat k v [Heap k v] Heap.singleton : k -> v -> Heap k v Heap.singleton k v = Heap 1 k v [] diff --git a/unison-src/demo/1.u b/unison-src/demo/1.u index 02ccb456de..807db03160 100644 --- a/unison-src/demo/1.u +++ b/unison-src/demo/1.u @@ -2,5 +2,4 @@ increment : Nat -> Nat increment n = n + 1 > x = 1 + 40 -> increment x - +> increment x \ No newline at end of file diff --git a/unison-src/errors/X-array.u b/unison-src/errors/X-array.u index 6323617195..9d5d695304 100644 --- a/unison-src/errors/X-array.u +++ b/unison-src/errors/X-array.u @@ -1,4 +1,4 @@ -type X = S Text | I Nat +structural type X = S Text | I Nat foo : a -> b -> c -> X foo x y z = X.S "" diff --git a/unison-src/errors/abort-ability-checks-against-pure.u b/unison-src/errors/abort-ability-checks-against-pure.u index 1d41bf7a1e..9f8c87ae67 100644 --- a/unison-src/errors/abort-ability-checks-against-pure.u +++ b/unison-src/errors/abort-ability-checks-against-pure.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a bork = u -> 1 + (Abort.Abort ()) diff --git a/unison-src/errors/all-errors.u b/unison-src/errors/all-errors.u index 91d44a3e79..ccf865a8a8 100644 --- a/unison-src/errors/all-errors.u +++ b/unison-src/errors/all-errors.u @@ -1,9 +1,9 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a Abort2' : forall a . () -> {Abort2} a diff --git a/unison-src/errors/check-for-regressions/lens.u b/unison-src/errors/check-for-regressions/lens.u index 9a4e4b1cd0..eed7ed9005 100644 --- a/unison-src/errors/check-for-regressions/lens.u +++ b/unison-src/errors/check-for-regressions/lens.u @@ -1,4 +1,4 @@ -type Foo a b = Foo a b +structural type Foo a b = Foo a b use Foo Foo use Optional Some setA : Foo a b -> Optional a -> Foo a b diff --git a/unison-src/errors/effect-inference1.u b/unison-src/errors/effect-inference1.u index d65321e992..dac87a3a0c 100644 --- a/unison-src/errors/effect-inference1.u +++ b/unison-src/errors/effect-inference1.u @@ -1,4 +1,4 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a foo n = if n >= 1000 then n else !Abort.Abort diff --git a/unison-src/errors/effect_unknown_type.uu b/unison-src/errors/effect_unknown_type.uu index 37fb492e4b..f8ff89919f 100755 --- a/unison-src/errors/effect_unknown_type.uu +++ b/unison-src/errors/effect_unknown_type.uu @@ -1,4 +1,4 @@ -ability T where +structural ability T where a : Unknown -> {T} () --b : Unknown diff --git a/unison-src/errors/handle-inference.u b/unison-src/errors/handle-inference.u index 8d5dc87c7a..24354124be 100644 --- a/unison-src/errors/handle-inference.u +++ b/unison-src/errors/handle-inference.u @@ -1,5 +1,5 @@ --handle inference -ability State s where +structural ability State s where get : βˆ€ s . () -> {State s} s set : βˆ€ s . s -> {State s} () state : βˆ€ a s . s -> Request (State s) a -> a diff --git a/unison-src/errors/handler-coverage-checking.uu b/unison-src/errors/handler-coverage-checking.uu index 134519ef01..fe22fb9b06 100644 --- a/unison-src/errors/handler-coverage-checking.uu +++ b/unison-src/errors/handler-coverage-checking.uu @@ -1,5 +1,5 @@ --State3 ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se diff --git a/unison-src/errors/io-effect.u b/unison-src/errors/io-effect.u index 7373163531..f11aad5eae 100644 --- a/unison-src/errors/io-effect.u +++ b/unison-src/errors/io-effect.u @@ -1,5 +1,5 @@ --IO ability -ability IO where +structural ability IO where launchMissiles : () -> {IO} () -- binding is not guarded by a lambda, it only can access -- ambient abilities (which will be empty) diff --git a/unison-src/errors/io-state1.u b/unison-src/errors/io-state1.u index a9d1c11c6a..f37b64402e 100644 --- a/unison-src/errors/io-state1.u +++ b/unison-src/errors/io-state1.u @@ -1,7 +1,7 @@ --IO/State1 ability -ability IO where +structural ability IO where launchMissiles : {IO} () -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se foo : () -> {IO} () diff --git a/unison-src/errors/map-traverse3.u b/unison-src/errors/map-traverse3.u index 724a5bdeee..8db0f0d035 100644 --- a/unison-src/errors/map-traverse3.u +++ b/unison-src/errors/map-traverse3.u @@ -1,8 +1,8 @@ --map/traverse -ability Noop where +structural ability Noop where noop : a -> {Noop} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : (a ->{} b) -> List a -> List b map f = cases diff --git a/unison-src/errors/need-nominal-type.uu b/unison-src/errors/need-nominal-type.uu index 14b48ed3cc..f110f17b92 100644 --- a/unison-src/errors/need-nominal-type.uu +++ b/unison-src/errors/need-nominal-type.uu @@ -1,5 +1,5 @@ -type Foo = Foo -type Bar = Bar +structural type Foo = Foo +structural type Bar = Bar x : Foo x = Bar.Bar diff --git a/unison-src/errors/poor-error-message/handle.u b/unison-src/errors/poor-error-message/handle.u index 6f476f6890..baa69403f8 100644 --- a/unison-src/errors/poor-error-message/handle.u +++ b/unison-src/errors/poor-error-message/handle.u @@ -5,9 +5,9 @@ -- 27 | let -- -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/errors/poor-error-message/handler-ex.u b/unison-src/errors/poor-error-message/handler-ex.u index 9e07c1262c..94c5129b01 100644 --- a/unison-src/errors/poor-error-message/handler-ex.u +++ b/unison-src/errors/poor-error-message/handler-ex.u @@ -11,7 +11,7 @@ -- -- Verbiage could be improved, but also the `()` location should -- point to line 22, the `k ()` call. -ability Ask foo where +structural ability Ask foo where ask : () -> {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/errors/poor-error-message/mismatched-case-result-types.u b/unison-src/errors/poor-error-message/mismatched-case-result-types.u index e1dd520475..aa02487789 100644 --- a/unison-src/errors/poor-error-message/mismatched-case-result-types.u +++ b/unison-src/errors/poor-error-message/mismatched-case-result-types.u @@ -1,5 +1,5 @@ --mismatched case result types -type Optional a = None | Some a +structural type Optional a = None | Some a match Optional.Some 3 with x -> 1 y -> "boo" diff --git a/unison-src/errors/poor-error-message/notaguard.u b/unison-src/errors/poor-error-message/notaguard.u index 54c3f0e373..8c38d07835 100644 --- a/unison-src/errors/poor-error-message/notaguard.u +++ b/unison-src/errors/poor-error-message/notaguard.u @@ -10,7 +10,7 @@ -- -- even though this program doesn't use guards! -ability Ask a where +structural ability Ask a where ask : {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u b/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u index 4f9b25c325..d5e453673c 100644 --- a/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u +++ b/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P +structural type Board = Board P P use Board.Board use P O X E diff --git a/unison-src/errors/poor-error-message/pattern-matching-1.u b/unison-src/errors/poor-error-message/pattern-matching-1.u index 2e53532d39..307d94b6cf 100644 --- a/unison-src/errors/poor-error-message/pattern-matching-1.u +++ b/unison-src/errors/poor-error-message/pattern-matching-1.u @@ -1,7 +1,7 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/errors/state4.u b/unison-src/errors/state4.u index b4890f65e7..82b859a75c 100644 --- a/unison-src/errors/state4.u +++ b/unison-src/errors/state4.u @@ -1,5 +1,5 @@ --State4 ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se -- binding is not guarded by a lambda, it only can access diff --git a/unison-src/errors/term-functor-inspired/effect1.u b/unison-src/errors/term-functor-inspired/effect1.u index 1c3f007c35..b072637846 100644 --- a/unison-src/errors/term-functor-inspired/effect1.u +++ b/unison-src/errors/term-functor-inspired/effect1.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where get : () -> {State s} s set : s -> {State s} () diff --git a/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u b/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u index 3aed71fd9f..e72f3be973 100644 --- a/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u +++ b/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u @@ -1,5 +1,5 @@ --mismatched case result types -type Optional a = None | Some a +structural type Optional a = None | Some a match Optional.Some 3 with x -> 1 y -> "boo" diff --git a/unison-src/errors/type-apply.u b/unison-src/errors/type-apply.u index c44b882242..ed179147cf 100644 --- a/unison-src/errors/type-apply.u +++ b/unison-src/errors/type-apply.u @@ -1,5 +1,5 @@ --Type.apply -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : βˆ€ a b . (a -> b) -> List a -> List b map f = cases List.Nil -> List.Nil diff --git a/unison-src/errors/type-functor-inspired/app2.u b/unison-src/errors/type-functor-inspired/app2.u index b9b422b846..2e9c3e9a4e 100644 --- a/unison-src/errors/type-functor-inspired/app2.u +++ b/unison-src/errors/type-functor-inspired/app2.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None app' : Optional Int app' = 3 () diff --git a/unison-src/errors/type-functor-inspired/effect2.u b/unison-src/errors/type-functor-inspired/effect2.u index 90615b8ea8..1ba2444ccc 100644 --- a/unison-src/errors/type-functor-inspired/effect2.u +++ b/unison-src/errors/type-functor-inspired/effect2.u @@ -1,7 +1,7 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a Abort2' : forall a . () -> {Abort2} a diff --git a/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu b/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu index dc731e635f..a2ad932a78 100644 --- a/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu +++ b/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu @@ -1,7 +1,7 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a ability' : Nat -> { Abort } Int diff --git a/unison-src/errors/type-functor-inspired/parens.u b/unison-src/errors/type-functor-inspired/parens.u index 22d02da2db..8d230bb0d4 100644 --- a/unison-src/errors/type-functor-inspired/parens.u +++ b/unison-src/errors/type-functor-inspired/parens.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None y : (Optional Int) y = 3 () \ No newline at end of file diff --git a/unison-src/errors/type-functor-inspired/subtuple.u b/unison-src/errors/type-functor-inspired/subtuple.u index f1aab6f7fd..a8d884af66 100644 --- a/unison-src/errors/type-functor-inspired/subtuple.u +++ b/unison-src/errors/type-functor-inspired/subtuple.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None z' : (Optional Int, Optional Text, Optional Float) z' = (None, 3) diff --git a/unison-src/errors/type-functor-inspired/tuple.u b/unison-src/errors/type-functor-inspired/tuple.u index e7f0019f78..1e957855c3 100644 --- a/unison-src/errors/type-functor-inspired/tuple.u +++ b/unison-src/errors/type-functor-inspired/tuple.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None z : (Optional Int, Optional Text, Optional Float) z = 3 () \ No newline at end of file diff --git a/unison-src/errors/unexpected-loop.u b/unison-src/errors/unexpected-loop.u index 16cada0892..175fe1df6f 100644 --- a/unison-src/errors/unexpected-loop.u +++ b/unison-src/errors/unexpected-loop.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a use Nat + diff --git a/unison-src/errors/unsound-cont.u b/unison-src/errors/unsound-cont.u index f05745d9fa..b9d14d1167 100644 --- a/unison-src/errors/unsound-cont.u +++ b/unison-src/errors/unsound-cont.u @@ -1,5 +1,5 @@ -ability Ask a where +structural ability Ask a where ask : {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/tests/344.uu b/unison-src/tests/344.uu index 6749329c28..32c12664df 100644 --- a/unison-src/tests/344.uu +++ b/unison-src/tests/344.uu @@ -1,5 +1,5 @@ -ability Either a b where +structural ability Either a b where left : a -> {Either a b} () right : b -> {Either a b} () -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b diff --git a/unison-src/tests/595.u b/unison-src/tests/595.u index b6383b6b58..d8a4eb18f7 100644 --- a/unison-src/tests/595.u +++ b/unison-src/tests/595.u @@ -1,5 +1,5 @@ -type Any = Any (βˆ€ r . (βˆ€ a . a -> r) -> r) +structural type Any = Any (βˆ€ r . (βˆ€ a . a -> r) -> r) -- also typechecks as expected any : a -> Any diff --git a/unison-src/tests/868.u b/unison-src/tests/868.u index 21cef2773a..51866a2191 100644 --- a/unison-src/tests/868.u +++ b/unison-src/tests/868.u @@ -1,5 +1,5 @@ -type Choice = First | Second -type Wrapper = Wrapper Choice +structural type Choice = First | Second +structural type Wrapper = Wrapper Choice broken = match Wrapper.Wrapper Choice.Second with Wrapper.Wrapper Choice.First -> true diff --git a/unison-src/tests/a-tale-of-two-optionals.u b/unison-src/tests/a-tale-of-two-optionals.u index d91fafa6e6..40489216bc 100644 --- a/unison-src/tests/a-tale-of-two-optionals.u +++ b/unison-src/tests/a-tale-of-two-optionals.u @@ -1,4 +1,4 @@ -type Optional a = None | Some a +structural type Optional a = None | Some a Optional.isEmpty : Optional a -> Boolean Optional.isEmpty = cases diff --git a/unison-src/tests/ability-inference-fail.uu b/unison-src/tests/ability-inference-fail.uu index e0dfbf2d7f..d09a8daddb 100644 --- a/unison-src/tests/ability-inference-fail.uu +++ b/unison-src/tests/ability-inference-fail.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream a = Stream ('{Emit a} ()) +structural type Stream a = Stream ('{Emit a} ()) use Stream Stream use Optional None Some diff --git a/unison-src/tests/ability-keyword.u b/unison-src/tests/ability-keyword.u index afe11e7a94..f0c4ad8a01 100644 --- a/unison-src/tests/ability-keyword.u +++ b/unison-src/tests/ability-keyword.u @@ -1,7 +1,6 @@ - -ability Foo where +structural ability Foo where foo : {Foo} Text x = 'let y = Foo.foo - () + () \ No newline at end of file diff --git a/unison-src/tests/abort.u b/unison-src/tests/abort.u index f5649ac457..a6e9fd8d2e 100644 --- a/unison-src/tests/abort.u +++ b/unison-src/tests/abort.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a eff : forall a b . (a -> b) -> b -> Request Abort a -> b eff f z = cases diff --git a/unison-src/tests/ask-inferred.u b/unison-src/tests/ask-inferred.u index 266eb12e2c..387ab27db9 100644 --- a/unison-src/tests/ask-inferred.u +++ b/unison-src/tests/ask-inferred.u @@ -1,14 +1,14 @@ --Ask inferred -ability Ask a where +structural ability Ask a where ask : {Ask a} a -ability AskU where +structural ability AskU where ask : {AskU} Nat use Nat + -ability AskT where +structural ability AskT where ask : {AskT} Text x = '(Ask.ask + 1) diff --git a/unison-src/tests/cce.u b/unison-src/tests/cce.u index f7bb084729..de53c56965 100644 --- a/unison-src/tests/cce.u +++ b/unison-src/tests/cce.u @@ -1,9 +1,9 @@ use Universal < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -16,7 +16,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r @@ -51,7 +51,7 @@ List.map f as = Some a -> go f (acc `snoc` f a) as (i + 1) go f [] as 0 -type Monoid a = Monoid (a -> a -> a) a +structural type Monoid a = Monoid (a -> a -> a) a Monoid.zero = cases Monoid.Monoid op z -> z Monoid.op = cases Monoid.Monoid op z -> op diff --git a/unison-src/tests/console.u b/unison-src/tests/console.u index 881c2ed157..a8f0792274 100644 --- a/unison-src/tests/console.u +++ b/unison-src/tests/console.u @@ -1,8 +1,8 @@ -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/console1.u b/unison-src/tests/console1.u index c29d7b7ebf..71fc616d03 100644 --- a/unison-src/tests/console1.u +++ b/unison-src/tests/console1.u @@ -1,11 +1,11 @@ -- This confusingly gives an error that -- it doesn't know what `Console.simulate` is. -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/data-references-builtins.u b/unison-src/tests/data-references-builtins.u index 099ef4e284..80d6ea7dc1 100644 --- a/unison-src/tests/data-references-builtins.u +++ b/unison-src/tests/data-references-builtins.u @@ -1,4 +1,4 @@ --data references builtins -type StringOrInt = S Text | I Nat +structural type StringOrInt = S Text | I Nat > [StringOrInt.S "YO", StringOrInt.I 1] diff --git a/unison-src/tests/delay.u b/unison-src/tests/delay.u index 0935bbabb3..f40e9ed99e 100644 --- a/unison-src/tests/delay.u +++ b/unison-src/tests/delay.u @@ -1,5 +1,5 @@ -type Foo a = Foo a +structural type Foo a = Foo a (+) = (Nat.+) diff --git a/unison-src/tests/delay_parse.u b/unison-src/tests/delay_parse.u index 525f62eaa4..cf7b6e5699 100644 --- a/unison-src/tests/delay_parse.u +++ b/unison-src/tests/delay_parse.u @@ -1,4 +1,4 @@ -ability T where +structural ability T where foo : {T} () -- parses fine diff --git a/unison-src/tests/effect-instantiation.u b/unison-src/tests/effect-instantiation.u index 5ec6e1679b..6ef57c7cf8 100644 --- a/unison-src/tests/effect-instantiation.u +++ b/unison-src/tests/effect-instantiation.u @@ -2,7 +2,7 @@ blah : a -> a -> a blah a a2 = a2 -ability Foo where +structural ability Foo where foo : {Foo} Text -- previously this didn't work as first argument was pure diff --git a/unison-src/tests/effect-instantiation2.u b/unison-src/tests/effect-instantiation2.u index 6a12abb9ab..a47aea5aa5 100644 --- a/unison-src/tests/effect-instantiation2.u +++ b/unison-src/tests/effect-instantiation2.u @@ -2,7 +2,7 @@ woot : a -> a -> a woot a a2 = a -ability Hi where +structural ability Hi where hi : Float ->{Hi} Int > woot Float.floor Hi.hi diff --git a/unison-src/tests/effect1.u b/unison-src/tests/effect1.u index 81c772401b..aa0c2135d9 100644 --- a/unison-src/tests/effect1.u +++ b/unison-src/tests/effect1.u @@ -4,5 +4,5 @@ eff f z = cases { Abort.Abort _ -> k } -> z { a } -> f a -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a diff --git a/unison-src/tests/fix1185.u b/unison-src/tests/fix1185.u index a897cc17f1..0cea2dc591 100644 --- a/unison-src/tests/fix1185.u +++ b/unison-src/tests/fix1185.u @@ -8,7 +8,7 @@ -- This file won't typecheck unless the definitions get -- the correct inferred types. -ability Zonk where +structural ability Zonk where zonk : Nat -- should be inferred as: diff --git a/unison-src/tests/fix1695.u b/unison-src/tests/fix1695.u index a605acf2e4..91fdb5762d 100644 --- a/unison-src/tests/fix1695.u +++ b/unison-src/tests/fix1695.u @@ -1,5 +1,5 @@ -ability G a where +structural ability G a where get : a f x y = diff --git a/unison-src/tests/fix528.u b/unison-src/tests/fix528.u index c0dff14ec0..b93591ff17 100644 --- a/unison-src/tests/fix528.u +++ b/unison-src/tests/fix528.u @@ -4,7 +4,7 @@ a |> f = f a ex1 = "bob" |> (Text.++) "hi, " -type Woot = Woot Text Int Nat +structural type Woot = Woot Text Int Nat ex2 = match 0 |> Woot "Zonk" +10 with Woot.Woot _ i _ -> i diff --git a/unison-src/tests/fix739.u b/unison-src/tests/fix739.u index 28d36405c4..43d914f444 100644 --- a/unison-src/tests/fix739.u +++ b/unison-src/tests/fix739.u @@ -1,4 +1,4 @@ -type MonoidRec a = { +structural type MonoidRec a = { combine : a -> a -> a, empty : a } diff --git a/unison-src/tests/force.u b/unison-src/tests/force.u index b4e1d2bdf8..2c33b014d5 100644 --- a/unison-src/tests/force.u +++ b/unison-src/tests/force.u @@ -1,4 +1,4 @@ -ability Woot where woot : {Woot} Text +structural ability Woot where woot : {Woot} Text force : '{e} a ->{e} a force a = !a diff --git a/unison-src/tests/guard-boolean-operators.u b/unison-src/tests/guard-boolean-operators.u index a5da96a178..fc04e5468e 100644 --- a/unison-src/tests/guard-boolean-operators.u +++ b/unison-src/tests/guard-boolean-operators.u @@ -1,4 +1,4 @@ -type Foo = Foo Boolean Boolean +structural type Foo = Foo Boolean Boolean f : Foo -> Boolean f = cases diff --git a/unison-src/tests/handler-stacking.u b/unison-src/tests/handler-stacking.u index 97d4322ee1..46c2d5c456 100644 --- a/unison-src/tests/handler-stacking.u +++ b/unison-src/tests/handler-stacking.u @@ -15,11 +15,11 @@ replicate n x = !x replicate (n `drop` 1) x -ability State a where +structural ability State a where get : {State a} a put : a -> {State a} () -ability Writer w where +structural ability Writer w where tell : w -> {Writer w} () stateHandler : s -> Request {State s} a -> (s, a) diff --git a/unison-src/tests/hang.u b/unison-src/tests/hang.u index 75702f8ef5..49cd4210af 100644 --- a/unison-src/tests/hang.u +++ b/unison-src/tests/hang.u @@ -1,10 +1,10 @@ use Universal == < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -17,7 +17,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r diff --git a/unison-src/tests/id.u b/unison-src/tests/id.u index 7d0bd3d4d2..39b03ed544 100644 --- a/unison-src/tests/id.u +++ b/unison-src/tests/id.u @@ -1,5 +1,4 @@ id : a -> a id x = x -> id - +> id \ No newline at end of file diff --git a/unison-src/tests/if.u b/unison-src/tests/if.u index e3af85295c..cc1e77684a 100644 --- a/unison-src/tests/if.u +++ b/unison-src/tests/if.u @@ -1,2 +1,2 @@ foo = if true then true else false -> foo +> foo \ No newline at end of file diff --git a/unison-src/tests/io-state2.u b/unison-src/tests/io-state2.u index e5ac00d21c..48f825cb86 100644 --- a/unison-src/tests/io-state2.u +++ b/unison-src/tests/io-state2.u @@ -1,5 +1,5 @@ --IO/State2 ability -ability IO where +structural ability IO where launchMissiles : {IO} () foo : Int -> {IO} Int @@ -12,10 +12,10 @@ foo unit = +42 +43 -type Optional a = +structural type Optional a = Some a | None -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . {State se} se diff --git a/unison-src/tests/io-state3.u b/unison-src/tests/io-state3.u index ca05a59cd0..9167be8a05 100644 --- a/unison-src/tests/io-state3.u +++ b/unison-src/tests/io-state3.u @@ -1,5 +1,5 @@ --IO3 ability -ability IO where +structural ability IO where launchMissiles : () -> {IO} () -- binding IS guarded, so its body can access whatever abilities -- are declared by the type of the binding diff --git a/unison-src/tests/map-traverse.u b/unison-src/tests/map-traverse.u index 980927ca77..95b884e847 100644 --- a/unison-src/tests/map-traverse.u +++ b/unison-src/tests/map-traverse.u @@ -1,11 +1,11 @@ --map/traverse -ability Noop where +structural ability Noop where noop : βˆ€ a . a -> {Noop} a -ability Noop2 where +structural ability Noop2 where noop2 : βˆ€ a . a -> a -> {Noop2} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : βˆ€ a b e . (a -> {e} b) -> List a -> {e} (List b) map f = cases diff --git a/unison-src/tests/map-traverse2.u b/unison-src/tests/map-traverse2.u index 61ee14c168..aba52594af 100644 --- a/unison-src/tests/map-traverse2.u +++ b/unison-src/tests/map-traverse2.u @@ -1,11 +1,11 @@ --map/traverse -ability Noop where +structural ability Noop where noop : a -> {Noop} a -ability Noop2 where +structural ability Noop2 where noop2 : a -> a -> {Noop2} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : (a -> b) -> List a -> List b map f = cases diff --git a/unison-src/tests/methodical/abilities.u b/unison-src/tests/methodical/abilities.u index 339fb25577..0192082bd7 100644 --- a/unison-src/tests/methodical/abilities.u +++ b/unison-src/tests/methodical/abilities.u @@ -1,7 +1,7 @@ -- ABILITIES -ability A where +structural ability A where woot : {A} Nat unA = cases @@ -15,7 +15,7 @@ a1 = handle x with unA -ability B where +structural ability B where zing : {B} Int abh = cases @@ -43,7 +43,7 @@ ab2 = with nh with abh -ability C where +structural ability C where n : Nat i : Int diff --git a/unison-src/tests/methodical/apply-constructor.u b/unison-src/tests/methodical/apply-constructor.u index a652f0cba4..9b3e98aa1f 100644 --- a/unison-src/tests/methodical/apply-constructor.u +++ b/unison-src/tests/methodical/apply-constructor.u @@ -2,7 +2,7 @@ -- Now check exact and underapply cases for constructors -- (overapply of a constructor is always a type error) -type Woot = Woot Nat Nat Nat Nat +structural type Woot = Woot Nat Nat Nat Nat toSeq : Woot -> [Nat] toSeq = cases diff --git a/unison-src/tests/methodical/cycle-minimize.u b/unison-src/tests/methodical/cycle-minimize.u index fc6356e719..837bb58ca2 100644 --- a/unison-src/tests/methodical/cycle-minimize.u +++ b/unison-src/tests/methodical/cycle-minimize.u @@ -1,5 +1,5 @@ -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> () -- should typecheck fine, as the `launchMissiles "saturn"` diff --git a/unison-src/tests/methodical/overapply-ability.u b/unison-src/tests/methodical/overapply-ability.u index 539871c4f4..bb6dfab74d 100644 --- a/unison-src/tests/methodical/overapply-ability.u +++ b/unison-src/tests/methodical/overapply-ability.u @@ -2,7 +2,7 @@ -- A corner case in the runtime is when a function is being overapplied and -- the exactly applied function requests an ability (and returns a new function) -ability Zing where +structural ability Zing where zing : Nat -> {Zing} (Nat -> Nat) zing2 : Nat -> Nat ->{Zing} (Nat -> Nat -> [Nat]) diff --git a/unison-src/tests/multiple-effects.u b/unison-src/tests/multiple-effects.u index e01edb87b6..12c636a523 100644 --- a/unison-src/tests/multiple-effects.u +++ b/unison-src/tests/multiple-effects.u @@ -1,8 +1,8 @@ -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/pattern-matching.u b/unison-src/tests/pattern-matching.u index 866fbb887d..b1e2b3c7e7 100644 --- a/unison-src/tests/pattern-matching.u +++ b/unison-src/tests/pattern-matching.u @@ -1,8 +1,8 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c -type List a = Nil | Cons a (List a) +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c +structural type List a = Nil | Cons a (List a) use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/tests/pattern-matching2.u b/unison-src/tests/pattern-matching2.u index 7bd1bf069b..4f6dd8c402 100644 --- a/unison-src/tests/pattern-matching2.u +++ b/unison-src/tests/pattern-matching2.u @@ -1,7 +1,7 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/tests/pattern-typing-bug.u b/unison-src/tests/pattern-typing-bug.u index 5ac1d44814..d9bbdf185a 100644 --- a/unison-src/tests/pattern-typing-bug.u +++ b/unison-src/tests/pattern-typing-bug.u @@ -1,4 +1,4 @@ -type Value = String Text +structural type Value = String Text | Bool Boolean f : Value -> Nat diff --git a/unison-src/tests/r1.u b/unison-src/tests/r1.u index 855e2d2bf1..3bc960ab01 100644 --- a/unison-src/tests/r1.u +++ b/unison-src/tests/r1.u @@ -1,5 +1,5 @@ --r1 -type Optional a = None | Some a +structural type Optional a = None | Some a r1 : Nat r1 = match Optional.Some 3 with x -> 1 diff --git a/unison-src/tests/r2.u b/unison-src/tests/r2.u index a3b925bc1e..8218decb76 100644 --- a/unison-src/tests/r2.u +++ b/unison-src/tests/r2.u @@ -1,4 +1,4 @@ -type Optional a = None | Some a +structural type Optional a = None | Some a r2 : Nat r2 = match Optional.Some true with Optional.Some true -> 1 diff --git a/unison-src/tests/rainbow.u b/unison-src/tests/rainbow.u index 378118d1d5..30befdb068 100644 --- a/unison-src/tests/rainbow.u +++ b/unison-src/tests/rainbow.u @@ -21,10 +21,10 @@ rainbow x = d = (Ask.ask : Int) +42 -ability Ask a where +structural ability Ask a where ask : {Ask a} a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b unique ability Zang where zang : {Zang} Nat diff --git a/unison-src/tests/records.u b/unison-src/tests/records.u index 2528896a65..907e184743 100644 --- a/unison-src/tests/records.u +++ b/unison-src/tests/records.u @@ -1,9 +1,9 @@ -type Point x y = { x : x, y : y } +structural type Point x y = { x : x, y : y } -type Point2 = { point2 : Nat, f : Nat } +structural type Point2 = { point2 : Nat, f : Nat } -type Monoid a = { zero : a, plus : a -> a -> a } +structural type Monoid a = { zero : a, plus : a -> a -> a } > Point.x.set 10 (Point 0 0) > Point.x (Point 10 0) diff --git a/unison-src/tests/sequence-literal-argument-parsing.u b/unison-src/tests/sequence-literal-argument-parsing.u index 8005a67566..d6d495bcaf 100644 --- a/unison-src/tests/sequence-literal-argument-parsing.u +++ b/unison-src/tests/sequence-literal-argument-parsing.u @@ -1,4 +1,4 @@ -type X a = X [a] +structural type X a = X [a] f : X a -> a f = cases diff --git a/unison-src/tests/soe.u b/unison-src/tests/soe.u index dd3b2c62b8..0ce0392ee1 100644 --- a/unison-src/tests/soe.u +++ b/unison-src/tests/soe.u @@ -1,10 +1,10 @@ use Universal == < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -17,7 +17,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r @@ -50,7 +50,7 @@ List.map f as = Some a -> go f (acc `snoc` f a) as (i + 1) go f [] as 0 -type Monoid a = Monoid (a -> a -> a) a +structural type Monoid a = Monoid (a -> a -> a) a Monoid.zero = cases Monoid.Monoid op z -> z Monoid.op = cases Monoid.Monoid op z -> op diff --git a/unison-src/tests/spurious-ability-fail-underapply.u b/unison-src/tests/spurious-ability-fail-underapply.u index 64cec3c053..1d14530288 100644 --- a/unison-src/tests/spurious-ability-fail-underapply.u +++ b/unison-src/tests/spurious-ability-fail-underapply.u @@ -1,4 +1,4 @@ -ability Woot where +structural ability Woot where woot : {Woot} Nat wha : ((a ->{Woot} a) -> a ->{Woot} a) -> Nat diff --git a/unison-src/tests/state1.u b/unison-src/tests/state1.u index 61b0e2cb98..4a529b303b 100644 --- a/unison-src/tests/state1.u +++ b/unison-src/tests/state1.u @@ -1,5 +1,5 @@ --State1 ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se diff --git a/unison-src/tests/state1a.u b/unison-src/tests/state1a.u index 471170b869..ed588573c7 100644 --- a/unison-src/tests/state1a.u +++ b/unison-src/tests/state1a.u @@ -1,5 +1,5 @@ --State1a ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . {State se} se id : Int -> Int diff --git a/unison-src/tests/state2.u b/unison-src/tests/state2.u index 62337b1074..acf525f9b4 100644 --- a/unison-src/tests/state2.u +++ b/unison-src/tests/state2.u @@ -1,5 +1,5 @@ --State2 ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se state : βˆ€ s a . s -> Request (State s) a -> (s, a) diff --git a/unison-src/tests/state2a-min.u b/unison-src/tests/state2a-min.u index 63a632a703..c62a8c08c3 100644 --- a/unison-src/tests/state2a-min.u +++ b/unison-src/tests/state2a-min.u @@ -1,5 +1,5 @@ --State2 ability -ability State s where +structural ability State s where put : s -> {State s} () state : s -> Request (State s) a -> a diff --git a/unison-src/tests/state2a.u b/unison-src/tests/state2a.u index c2dcc58a00..cd98bbad2f 100644 --- a/unison-src/tests/state2a.u +++ b/unison-src/tests/state2a.u @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state2a.uu b/unison-src/tests/state2a.uu index 82a2306eb9..8b0dc5587a 100644 --- a/unison-src/tests/state2a.uu +++ b/unison-src/tests/state2a.uu @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state2b-min.u b/unison-src/tests/state2b-min.u index 257ca9e3e3..44c971cb80 100644 --- a/unison-src/tests/state2b-min.u +++ b/unison-src/tests/state2b-min.u @@ -1,5 +1,5 @@ --State2 ability -ability State s where +structural ability State s where put : s -> {State s} () state : s -> Request (State s) a -> s diff --git a/unison-src/tests/state2b.u b/unison-src/tests/state2b.u index b036ed0283..561ce71095 100644 --- a/unison-src/tests/state2b.u +++ b/unison-src/tests/state2b.u @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state3.u b/unison-src/tests/state3.u index cc15016819..bebb7d1637 100644 --- a/unison-src/tests/state3.u +++ b/unison-src/tests/state3.u @@ -1,5 +1,5 @@ --State3 ability -ability State se2 where +structural ability State se2 where put : βˆ€ se . se -> {State se} () get : βˆ€ se . () -> {State se} se diff --git a/unison-src/tests/state4.u b/unison-src/tests/state4.u index 3db4bd9c40..3ed0e7aba2 100644 --- a/unison-src/tests/state4.u +++ b/unison-src/tests/state4.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state4a.u b/unison-src/tests/state4a.u index 04544e9451..8455432d4a 100644 --- a/unison-src/tests/state4a.u +++ b/unison-src/tests/state4a.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/stream.u b/unison-src/tests/stream.u index f790e97df7..bd170a7042 100644 --- a/unison-src/tests/stream.u +++ b/unison-src/tests/stream.u @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some diff --git a/unison-src/tests/stream2.uu b/unison-src/tests/stream2.uu index fd2862d479..8daa0111db 100644 --- a/unison-src/tests/stream2.uu +++ b/unison-src/tests/stream2.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some diff --git a/unison-src/tests/stream3.uu b/unison-src/tests/stream3.uu index 3e6a2d5e8d..cbb3d1c6e1 100644 --- a/unison-src/tests/stream3.uu +++ b/unison-src/tests/stream3.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some @@ -50,7 +50,7 @@ namespace Stream where run : Stream e a r ->{e, Emit a} r run = cases Stream c -> !c -ability Abort where +structural ability Abort where abort : {Abort} a --- diff --git a/unison-src/tests/tictactoe.u b/unison-src/tests/tictactoe.u index e3dde4d4ba..390b69f33a 100644 --- a/unison-src/tests/tictactoe.u +++ b/unison-src/tests/tictactoe.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe0-array-oob1.u b/unison-src/tests/tictactoe0-array-oob1.u index 22989cd6e6..cbabf6b46e 100644 --- a/unison-src/tests/tictactoe0-array-oob1.u +++ b/unison-src/tests/tictactoe0-array-oob1.u @@ -1,6 +1,6 @@ -- board piece -type Board = Board Nat Nat Nat +structural type Board = Board Nat Nat Nat use Board Board diff --git a/unison-src/tests/tictactoe0-npe.u b/unison-src/tests/tictactoe0-npe.u index d1845df897..9edc4c58d6 100644 --- a/unison-src/tests/tictactoe0-npe.u +++ b/unison-src/tests/tictactoe0-npe.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe0.u b/unison-src/tests/tictactoe0.u index a6e0ff7a52..d0628f7205 100644 --- a/unison-src/tests/tictactoe0.u +++ b/unison-src/tests/tictactoe0.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe2.u b/unison-src/tests/tictactoe2.u index cf02bcc44c..9ebaf3b307 100644 --- a/unison-src/tests/tictactoe2.u +++ b/unison-src/tests/tictactoe2.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/type-application.u b/unison-src/tests/type-application.u index ae54823ad7..87b673809d 100644 --- a/unison-src/tests/type-application.u +++ b/unison-src/tests/type-application.u @@ -1,8 +1,8 @@ -ability Foo where +structural ability Foo where foo : {Foo} Nat -type Wrap a = Wrap Nat +structural type Wrap a = Wrap Nat blah : Wrap {Foo} -> Nat blah = cases diff --git a/unison-src/tests/ungeneralize-bug.uu b/unison-src/tests/ungeneralize-bug.uu index 5a5448ed17..f3fc3403c2 100644 --- a/unison-src/tests/ungeneralize-bug.uu +++ b/unison-src/tests/ungeneralize-bug.uu @@ -2,7 +2,7 @@ use Foo Foo use Optional Some None -type Foo a b = Foo a (Optional b) +structural type Foo a b = Foo a (Optional b) foo : Foo a b -> (b -> c) -> Foo a c foo x f = match x with diff --git a/unison-src/tests/void.u b/unison-src/tests/void.u index a4e646ad32..701265f629 100644 --- a/unison-src/tests/void.u +++ b/unison-src/tests/void.u @@ -1,3 +1,3 @@ -type Void = +structural type Void = > 3 diff --git a/unison-src/transcripts-round-trip/ex2.u b/unison-src/transcripts-round-trip/ex2.u new file mode 100644 index 0000000000..af175c38bb --- /dev/null +++ b/unison-src/transcripts-round-trip/ex2.u @@ -0,0 +1 @@ +b = 92384 diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md new file mode 100644 index 0000000000..803ac946d0 --- /dev/null +++ b/unison-src/transcripts-round-trip/main.md @@ -0,0 +1,214 @@ +This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added here as regression tests. Add tests at the bottom of this + +```ucm:hide +.> builtins.mergeio +.> load unison-src/transcripts-using-base/base.u +``` + +## How to use this transcript: checking round-trip for inline definitions + +```unison:hide +x = 1 + 1 +``` + +```ucm +.> add +.> edit x +.> reflog +.> reset-root 2 +``` + +Resetting the namespace after each example ensures they don't interact at all, which is probably what you want. + +The `load` command which does parsing and typechecking of the `edit`'d definitions needs to be in a separate stanza from the `edit` command. + +```ucm +.> load scratch.u +``` + +## How to use this transcript: checking round-trip for definitions from a file + +Examples can also be loaded from `.u` files: + +```ucm +.> load unison-src/transcripts-round-trip/ex2.u +.> add +``` + +When loading definitions from a file, an empty stanza like this will ensure that this empty file is where the definitions being `edit`'d will get dumped. + +```unison:hide +-- empty scratch file, `edit` will target this +``` + +Without the above stanza, the `edit` will send the definition to the most recently loaded file, which would be `ex2.u`, making the transcript not idempotent. + +```ucm +.> edit b +.> reflog +.> reset-root 2 +``` + +```ucm +.> load scratch.u +``` + +No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11` in the transcript to load all the definitions into the file. + +## Destructuring binds + +Regression test for https://github.com/unisonweb/unison/issues/2337 + +```unison:hide +unique type Blah = Blah Boolean Boolean + +f : Blah -> Boolean +f x = let + (Blah.Blah a b) = x + a +``` + +```ucm +.> add +.> edit Blah f +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + +## Parens around infix patterns + +Regression test for https://github.com/unisonweb/unison/issues/2224 + +```unison:hide +f : [a] -> a +f xs = match xs with + x +: (x' +: rest) -> x + +g : [a] -> a +g xs = match xs with + (rest :+ x') :+ x -> x + +h : [[a]] -> a +h xs = match xs with + (rest :+ (rest' :+ x)) -> x +``` + +```ucm +.> add +.> edit f g +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + +## Type application inserts necessary parens + +Regression test for https://github.com/unisonweb/unison/issues/2392 + +```unison:hide +unique ability Zonk where zonk : Nat +unique type Foo x y = + +foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat +foo n _ = n +``` + +```ucm +.> add +.> edit foo Zonk Foo +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + +## Long lines with repeated operators + +Regression test for https://github.com/unisonweb/unison/issues/1035 + +```unison:hide +foo : Text +foo = + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddddddddd" +``` + +```ucm +.> add +.> edit foo +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + +## Emphasis in docs inserts the right number of underscores + +Regression test for https://github.com/unisonweb/unison/issues/2408 + +```unison:hide +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*TEXT** }} +``` + +```ucm +.> add +.> edit myDoc +.> undo +``` + +``` ucm +.> load scratch.u +``` + +## Parenthesized let-block with operator + +Regression test for https://github.com/unisonweb/unison/issues/1778 + +```unison:hide + +structural ability base.Abort where + abort : a + +(|>) : a -> (a ->{e} b) -> {e} b +a |> f = f a + +handler : a -> Request {Abort} a -> a +handler default = cases + { a } -> a + {abort -> _} -> default + +Abort.toOptional : '{g, Abort} a -> '{g} Optional a +Abort.toOptional thunk = '(toOptional! thunk) + +Abort.toOptional! : '{g, Abort} a ->{g} (Optional a) +Abort.toOptional! thunk = toDefault! None '(Some !thunk) + +Abort.toDefault! : a -> '{g, Abort} a ->{g} a +Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle (thunk ()) with h + +x = '(let + abort + 0) |> Abort.toOptional +``` + +```ucm +.> add +.> edit x base.Abort |> handler Abort.toOptional Abort.toOptional! Abort.toDefault! +.> undo +``` + +``` ucm +.> load scratch.u +``` diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md new file mode 100644 index 0000000000..31b68ffe0c --- /dev/null +++ b/unison-src/transcripts-round-trip/main.output.md @@ -0,0 +1,642 @@ +This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added here as regression tests. Add tests at the bottom of this + +## How to use this transcript: checking round-trip for inline definitions + +```unison +x = 1 + 1 +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + x : Nat + +.> edit x + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + x : Nat + x = + use Nat + + 1 + 1 + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #j1vrihj69n : add + 2. #m41m2ql36i : builtins.mergeio + 3. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +Resetting the namespace after each example ensures they don't interact at all, which is probably what you want. + +The `load` command which does parsing and typechecking of the `edit`'d definitions needs to be in a separate stanza from the `edit` command. + +```ucm +.> load 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`: + + x : Nat + +``` +## How to use this transcript: checking round-trip for definitions from a file + +Examples can also be loaded from `.u` files: + +```ucm +.> load unison-src/transcripts-round-trip/ex2.u + + I found and typechecked these definitions in + unison-src/transcripts-round-trip/ex2.u. If you do an `add` or + `update`, here's how your codebase would change: + + ⍟ These new definitions are ok to `add`: + + b : Nat + +.> add + + ⍟ I've added these definitions: + + b : Nat + +``` +When loading definitions from a file, an empty stanza like this will ensure that this empty file is where the definitions being `edit`'d will get dumped. + +```unison +-- empty scratch file, `edit` will target this +``` + +Without the above stanza, the `edit` will send the definition to the most recently loaded file, which would be `ex2.u`, making the transcript not idempotent. + +```ucm +.> edit b + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + b : Nat + b = 92384 + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #sb99mm43ni : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #j1vrihj69n : add + 4. #m41m2ql36i : builtins.mergeio + 5. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load 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`: + + b : Nat + +``` +No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11` in the transcript to load all the definitions into the file. + +## Destructuring binds + +Regression test for https://github.com/unisonweb/unison/issues/2337 + +```unison +unique type Blah = Blah Boolean Boolean + +f : Blah -> Boolean +f x = let + (Blah.Blah a b) = x + a +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Blah + f : Blah -> Boolean + +.> edit Blah f + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + unique type Blah + = Blah Boolean Boolean + + f : Blah -> Boolean + f = cases Blah a b -> a + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #t22r3l1hsh : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #sb99mm43ni : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #j1vrihj69n : add + 6. #m41m2ql36i : builtins.mergeio + 7. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load 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`: + + unique type Blah + f : Blah -> Boolean + +``` +## Parens around infix patterns + +Regression test for https://github.com/unisonweb/unison/issues/2224 + +```unison +f : [a] -> a +f xs = match xs with + x +: (x' +: rest) -> x + +g : [a] -> a +g xs = match xs with + (rest :+ x') :+ x -> x + +h : [[a]] -> a +h xs = match xs with + (rest :+ (rest' :+ x)) -> x +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + f : [a] -> a + g : [a] -> a + h : [[a]] -> a + +.> edit f g + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + f : [a] -> a + f = cases x +: (x' +: rest) -> x + + g : [a] -> a + g = cases rest :+ x' :+ x -> x + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #ebh8598vf0 : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #t22r3l1hsh : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #sb99mm43ni : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #j1vrihj69n : add + 8. #m41m2ql36i : builtins.mergeio + 9. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load 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`: + + f : [a] -> a + g : [a] -> a + +``` +## Type application inserts necessary parens + +Regression test for https://github.com/unisonweb/unison/issues/2392 + +```unison +unique ability Zonk where zonk : Nat +unique type Foo x y = + +foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat +foo n _ = n +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Foo x y + unique ability Zonk + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + +.> edit foo Zonk Foo + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + unique type Foo x y + = + + unique ability Zonk where zonk : {Zonk} Nat + + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + foo n _ = n + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #siglm9vcnk : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #ebh8598vf0 : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #t22r3l1hsh : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #sb99mm43ni : add + 8. #m41m2ql36i : reset-root #m41m2ql36i + 9. #j1vrihj69n : add + 10. #m41m2ql36i : builtins.mergeio + 11. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load 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`: + + unique type Foo x y + unique ability Zonk + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + +``` +## Long lines with repeated operators + +Regression test for https://github.com/unisonweb/unison/issues/1035 + +```unison +foo : Text +foo = + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddddddddd" +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + foo : Text + +.> edit foo + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + foo : Text + foo = + use Text ++ + "aaaaaaaaaaaaaaaaaaaaaa" + ++ "bbbbbbbbbbbbbbbbbbbbbb" + ++ "cccccccccccccccccccccc" + ++ "dddddddddddddddddddddd" + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #m41m2ql36i .old` to make an old namespace + accessible again, + + `reset-root #m41m2ql36i` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #re8lsbbg6o : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #siglm9vcnk : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #ebh8598vf0 : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #t22r3l1hsh : add + 8. #m41m2ql36i : reset-root #m41m2ql36i + 9. #sb99mm43ni : add + 10. #m41m2ql36i : reset-root #m41m2ql36i + 11. #j1vrihj69n : add + 12. #m41m2ql36i : builtins.mergeio + 13. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load 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`: + + foo : Text + +``` +## Emphasis in docs inserts the right number of underscores + +Regression test for https://github.com/unisonweb/unison/issues/2408 + +```unison +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*TEXT** }} +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + myDoc : Doc2 + +.> edit myDoc + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + myDoc : Doc2 + myDoc = + {{ + **my text** __my text__ **MY_TEXT** ___MY__TEXT___ + ~~MY~TEXT~~ **MY*TEXT** + }} + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> undo + + Here are the changes I undid + + Added definitions: + + 1. myDoc : Doc2 + +``` +```ucm +.> load 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`: + + myDoc : Doc2 + +``` +## Parenthesized let-block with operator + +Regression test for https://github.com/unisonweb/unison/issues/1778 + +```unison +structural ability base.Abort where + abort : a + +(|>) : a -> (a ->{e} b) -> {e} b +a |> f = f a + +handler : a -> Request {Abort} a -> a +handler default = cases + { a } -> a + {abort -> _} -> default + +Abort.toOptional : '{g, Abort} a -> '{g} Optional a +Abort.toOptional thunk = '(toOptional! thunk) + +Abort.toOptional! : '{g, Abort} a ->{g} (Optional a) +Abort.toOptional! thunk = toDefault! None '(Some !thunk) + +Abort.toDefault! : a -> '{g, Abort} a ->{g} a +Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle (thunk ()) with h + +x = '(let + abort + 0) |> Abort.toOptional +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + structural ability base.Abort + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + handler : a -> Request {Abort} a -> a + x : 'Optional Nat + |> : a -> (a ->{e} b) ->{e} b + +.> edit x base.Abort |> handler Abort.toOptional Abort.toOptional! Abort.toDefault! + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + structural ability base.Abort where abort : {base.Abort} a + + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle !thunk with h + + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional thunk = '(toOptional! thunk) + + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + Abort.toOptional! thunk = toDefault! None '(Some !thunk) + + handler : a -> Request {Abort} a -> a + handler default = cases + { a } -> a + {abort -> _} -> default + + x : 'Optional Nat + x = + ('let + abort + 0) |> toOptional + + (|>) : a -> (a ->{e} b) ->{e} b + a |> f = f a + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> undo + + Here are the changes I undid + + Added definitions: + + 1. structural ability base.Abort + 2. base.Abort.abort : {#oup50kgmqv} a + 3. handler : a -> Request {#oup50kgmqv} a -> a + 4. Abort.toDefault! : a -> '{g, #oup50kgmqv} a ->{g} a + 5. Abort.toOptional : '{g, #oup50kgmqv} a + -> '{g} Optional a + 6. Abort.toOptional! : '{g, #oup50kgmqv} a ->{g} Optional a + 7. x : 'Optional Nat + 8. |> : a -> (a ->{e} b) ->{e} b + +``` +```ucm +.> load 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`: + + structural ability base.Abort + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + handler : a -> Request {Abort} a -> a + x : 'Optional Nat + |> : a -> (a ->{e} b) ->{e} b + +``` diff --git a/unison-src/transcripts-using-base/base.u b/unison-src/transcripts-using-base/base.u index 1d49c6dd8c..7e0b90ab9d 100644 --- a/unison-src/transcripts-using-base/base.u +++ b/unison-src/transcripts-using-base/base.u @@ -7,7 +7,7 @@ compose3 f g = a -> b -> c -> f (g a b c) id a = a -ability Exception where +structural ability Exception where raise: io2.Failure -> anything Exception.reraise : Either Failure a ->{Exception} a @@ -23,7 +23,7 @@ Exception.toEither.handler = cases Exception.toEither : '{Ξ΅, Exception} a -> {Ξ΅} Either Failure a Exception.toEither a = handle !a with Exception.toEither.handler -ability Throw e where +structural ability Throw e where throw : e -> a List.all : (a ->{Ξ΅} Boolean) -> [a] ->{Ξ΅} Boolean @@ -66,7 +66,7 @@ isNone = cases None -> true -ability Stream a where +structural ability Stream a where emit: a -> () Stream.toList.handler : Request {Stream a} r -> [a] @@ -97,7 +97,7 @@ Stream.collect s = -- An ability that facilitates creating temoporary directories that can be -- automatically cleaned up -ability TempDirs where +structural ability TempDirs where newTempDir: Text -> Text removeDir: Text -> () @@ -136,6 +136,11 @@ stdout = IO.stdHandle StdOut printText : Text -> {io2.IO} Either Failure () printText t = putBytes.impl stdout (toUtf8 t) +printLine : Text -> {io2.IO, Exception} () +printLine t = reraise (printText (t ++ "\n")) + +delay : Nat ->{IO, Exception} () +delay n = reraise (delay.impl n) -- Run tests which might fail, might create temporary directores and Stream out -- results, returns the Results and the result of the test evalTest: '{Stream Result, TempDirs, io2.IO, Exception} a ->{io2.IO, Exception}([Result], a) diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 7933a428cd..0f7841764a 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -36,7 +36,7 @@ identical err x y = then () else throw ("mismatch" ++ err) -type Three a b c = zero a | one b | two c +structural type Three a b c = zero a | one b | two c showThree : Three Nat Nat Nat -> Text showThree = cases @@ -89,7 +89,7 @@ identicality t x ``` ```unison -ability Zap where +structural ability Zap where zap : Three Nat Nat Nat h : Three Nat Nat Nat -> Nat -> Nat @@ -166,3 +166,34 @@ to actual show that the serialization works. .> io.test tests .> io.test badLoad ``` + +```unison +validateTest : Link.Term ->{IO} Result +validateTest l = match Code.lookup l with + None -> Fail "Couldn't look up link" + Some co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code pre" + None -> match Code.deserialize (Code.serialize co) with + Left _ -> Fail "code failed deserialization" + Right co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code post" + None -> Ok "validated" + +vtests : '{IO} [Result] +vtests _ = + List.map validateTest + [ termLink fib10 + , termLink compose + , termLink List.all + , termLink hex + , termLink isDirectory + , termLink delay + , termLink printLine + , termLink isNone + ] +``` + +```ucm +.> add +.> io.test vtests +``` diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index a2b7856d5e..8f8b2477f2 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -31,7 +31,7 @@ identical err x y = then () else throw ("mismatch" ++ err) -type Three a b c = zero a | one b | two c +structural type Three a b c = zero a | one b | two c showThree : Three Nat Nat Nat -> Text showThree = cases @@ -87,7 +87,7 @@ identicality t x ⍟ These new definitions are ok to `add`: - type Three a b c + structural type Three a b c concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -114,7 +114,7 @@ identicality t x ⍟ I've added these definitions: - type Three a b c + structural type Three a b c concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -137,7 +137,7 @@ identicality t x ``` ```unison -ability Zap where +structural ability Zap where zap : Three Nat Nat Nat h : Three Nat Nat Nat -> Nat -> Nat @@ -212,7 +212,7 @@ badLoad _ = ⍟ These new definitions are ok to `add`: - ability Zap + structural ability Zap badLoad : '{IO} [Result] f : Nat ->{Zap} Nat fDeps : [Link.Term] @@ -233,7 +233,7 @@ to actual show that the serialization works. ⍟ I've added these definitions: - ability Zap + structural ability Zap badLoad : '{IO} [Result] f : Nat ->{Zap} Nat fDeps : [Link.Term] @@ -281,3 +281,67 @@ to actual show that the serialization works. Tip: Use view badLoad to view the source of a test. ``` +```unison +validateTest : Link.Term ->{IO} Result +validateTest l = match Code.lookup l with + None -> Fail "Couldn't look up link" + Some co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code pre" + None -> match Code.deserialize (Code.serialize co) with + Left _ -> Fail "code failed deserialization" + Right co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code post" + None -> Ok "validated" + +vtests : '{IO} [Result] +vtests _ = + List.map validateTest + [ termLink fib10 + , termLink compose + , termLink List.all + , termLink hex + , termLink isDirectory + , termLink delay + , termLink printLine + , termLink isNone + ] +``` + +```ucm + + 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`: + + validateTest : Link.Term ->{IO} Result + vtests : '{IO} [Result] + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + validateTest : Link.Term ->{IO} Result + vtests : '{IO} [Result] + +.> io.test vtests + + New test results: + + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + β—‰ vtests validated + + βœ… 8 test(s) passing + + Tip: Use view vtests to view the source of a test. + +``` diff --git a/unison-src/transcripts-using-base/doc.md.files/syntax.u b/unison-src/transcripts-using-base/doc.md.files/syntax.u index 10b9b02921..a34ac8d503 100644 --- a/unison-src/transcripts-using-base/doc.md.files/syntax.u +++ b/unison-src/transcripts-using-base/doc.md.files/syntax.u @@ -5,7 +5,7 @@ basicFormatting = {{ Paragraphs are separated by one or more blanklines. Sections have a title and 0 or more paragraphs or other section elements. - Text can be __bold__, *italicized*, ~~strikethrough~~, or + Text can be **bold**, __italicized__, ~~strikethrough~~, or ''monospaced''. You can link to Unison terms, types, and external URLs: @@ -20,7 +20,7 @@ basicFormatting = {{ This is useful for creating documents programmatically or just including other documents. - *Next up:* {lists} + __Next up:__ {lists} }} lists = {{ @@ -168,7 +168,7 @@ This is an aside. {{ docAside {{ Some extra detail that doesn't belong in main t docBlockquote {{ "And what is the use of a book," thought Alice, "without pictures or conversation?" - *Lewis Carroll, Alice's Adventures in Wonderland* }} + _Lewis Carroll, Alice's Adventures in Wonderland_ }} }} {{ docTooltip {{Hover over me}} {{Extra detail}} }} diff --git a/unison-src/transcripts-using-base/doc.output.md b/unison-src/transcripts-using-base/doc.output.md index 38321c8895..d8699b61f2 100644 --- a/unison-src/transcripts-using-base/doc.output.md +++ b/unison-src/transcripts-using-base/doc.output.md @@ -113,8 +113,8 @@ and the rendered output using `display`: Sections have a title and 0 or more paragraphs or other section elements. - Text can be __bold__, *italicized*, ~~strikethrough~~, or - ''monospaced''. + Text can be **bold**, __italicized__, ~~strikethrough~~, + or ''monospaced''. You can link to Unison terms, types, and external URLs: @@ -129,7 +129,7 @@ and the rendered output using `display`: useful for creating documents programmatically or just including other documents. - *Next up:* {lists} + __Next up:__ {lists} }} .> display basicFormatting @@ -335,7 +335,7 @@ and the rendered output using `display`: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -343,7 +343,7 @@ and the rendered output using `display`: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -469,7 +469,7 @@ and the rendered output using `display`: "And what is the use of a book," thought Alice, "without pictures or conversation?" - *Lewis Carroll, Alice's Adventures in Wonderland* + __Lewis Carroll, Alice's Adventures in Wonderland__ }} }} {{ docTooltip {{ Hover over me }} {{ Extra detail }} }} @@ -637,7 +637,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -645,7 +645,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * diff --git a/unison-src/transcripts-using-base/fix2027.md b/unison-src/transcripts-using-base/fix2027.md index fc0fc9f7b8..23e9498cab 100644 --- a/unison-src/transcripts-using-base/fix2027.md +++ b/unison-src/transcripts-using-base/fix2027.md @@ -5,13 +5,13 @@ ``` ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x reraise = cases Left e -> raise e Right a -> a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b putBytes h bs = reraise (putBytes.impl h bs) diff --git a/unison-src/transcripts-using-base/fix2027.output.md b/unison-src/transcripts-using-base/fix2027.output.md index 59e3783331..c598d513e1 100644 --- a/unison-src/transcripts-using-base/fix2027.output.md +++ b/unison-src/transcripts-using-base/fix2027.output.md @@ -1,13 +1,13 @@ ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x reraise = cases Left e -> raise e Right a -> a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b putBytes h bs = reraise (putBytes.impl h bs) @@ -57,7 +57,7 @@ myServer = unsafeRun! '(hello "127.0.0.1" "0") ⍟ These new definitions are ok to `add`: - type Either a b + structural type Either a b (also named builtin.Either) Exception.unsafeRun! : '{g, Exception} a -> '{g} a bugFail : Failure -> r diff --git a/unison-src/transcripts-using-base/fix2158-1.md b/unison-src/transcripts-using-base/fix2158-1.md index c80faa3f1f..16721569e5 100644 --- a/unison-src/transcripts-using-base/fix2158-1.md +++ b/unison-src/transcripts-using-base/fix2158-1.md @@ -1,7 +1,7 @@ This transcript tests an ability check failure regression. ```unison -ability Async t g where +structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a diff --git a/unison-src/transcripts-using-base/fix2158-1.output.md b/unison-src/transcripts-using-base/fix2158-1.output.md index f9419e4a42..645cfe8013 100644 --- a/unison-src/transcripts-using-base/fix2158-1.output.md +++ b/unison-src/transcripts-using-base/fix2158-1.output.md @@ -1,7 +1,7 @@ This transcript tests an ability check failure regression. ```unison -ability Async t g where +structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a @@ -19,7 +19,7 @@ Async.parMap f as = ⍟ These new definitions are ok to `add`: - ability Async t g + structural ability Async t g Async.parMap : (a ->{g, Async t g} b) -> [a] ->{Async t g} [b] diff --git a/unison-src/transcripts-using-base/fix2297.output.md b/unison-src/transcripts-using-base/fix2297.output.md index a2a8f85a85..fb2aa368d6 100644 --- a/unison-src/transcripts-using-base/fix2297.output.md +++ b/unison-src/transcripts-using-base/fix2297.output.md @@ -27,9 +27,13 @@ wat = handleTrivial testAction -- Somehow this completely forgets about Excepti ```ucm - The expression in red needs the {Exception} ability, but this location does not have access to any abilities. + I expected to see `structural` or `unique` at the start of + this line: - 19 | wat = handleTrivial testAction -- Somehow this completely forgets about Exception and IO + 1 | ability Trivial where + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types ``` diff --git a/unison-src/transcripts-using-base/fix2358.md b/unison-src/transcripts-using-base/fix2358.md new file mode 100644 index 0000000000..ff37a70789 --- /dev/null +++ b/unison-src/transcripts-using-base/fix2358.md @@ -0,0 +1,18 @@ + +Tests a former error due to bad calling conventions on delay.impl + +```ucm:hide +.> builtins.mergeio +``` + +```unison +timingApp2 : '{IO, Exception} () +timingApp2 _ = + printLine "Hello" + delay 10 + printLine "World" +``` + +```ucm +.> run timingApp2 +``` diff --git a/unison-src/transcripts-using-base/fix2358.output.md b/unison-src/transcripts-using-base/fix2358.output.md new file mode 100644 index 0000000000..c4d87c9fbb --- /dev/null +++ b/unison-src/transcripts-using-base/fix2358.output.md @@ -0,0 +1,26 @@ + +Tests a former error due to bad calling conventions on delay.impl + +```unison +timingApp2 : '{IO, Exception} () +timingApp2 _ = + printLine "Hello" + delay 10 + printLine "World" +``` + +```ucm + + 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`: + + timingApp2 : '{IO, Exception} () + +``` +```ucm +.> run timingApp2 + +``` diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index 2f8c322478..a79fe660ce 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -27,13 +27,15 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.w 20. fromBase64 (Bytes -> Either Text Bytes) 21. fromBase64UrlUnpadded (Bytes -> Either Text Bytes) 22. fromList ([Nat] -> Bytes) - 23. size (Bytes -> Nat) - 24. take (Nat -> Bytes -> Bytes) - 25. toBase16 (Bytes -> Bytes) - 26. toBase32 (Bytes -> Bytes) - 27. toBase64 (Bytes -> Bytes) - 28. toBase64UrlUnpadded (Bytes -> Bytes) - 29. toList (Bytes -> [Nat]) + 23. gzip/ (2 definitions) + 24. size (Bytes -> Nat) + 25. take (Nat -> Bytes -> Bytes) + 26. toBase16 (Bytes -> Bytes) + 27. toBase32 (Bytes -> Bytes) + 28. toBase64 (Bytes -> Bytes) + 29. toBase64UrlUnpadded (Bytes -> Bytes) + 30. toList (Bytes -> [Nat]) + 31. zlib/ (2 definitions) ``` Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`. diff --git a/unison-src/transcripts/addupdatemessages.md b/unison-src/transcripts/addupdatemessages.md index 68f7be5a52..671d923ac5 100644 --- a/unison-src/transcripts/addupdatemessages.md +++ b/unison-src/transcripts/addupdatemessages.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. @@ -25,7 +25,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -type Z = One Nat +structural type Z = One Nat ``` Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. @@ -39,7 +39,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. @@ -52,7 +52,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -type X = Two Nat Nat +structural type X = Two Nat Nat ``` Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. diff --git a/unison-src/transcripts/addupdatemessages.output.md b/unison-src/transcripts/addupdatemessages.output.md index 424c9b08f2..ce3488b205 100644 --- a/unison-src/transcripts/addupdatemessages.output.md +++ b/unison-src/transcripts/addupdatemessages.output.md @@ -6,8 +6,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm @@ -18,8 +18,8 @@ type Y = Two Nat Nat ⍟ These new definitions are ok to `add`: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -33,8 +33,8 @@ Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. ⍟ I've added these definitions: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -44,7 +44,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -type Z = One Nat +structural type Z = One Nat ``` ```ucm @@ -55,7 +55,7 @@ type Z = One Nat ⍟ These new definitions are ok to `add`: - type Z + structural type Z (also named X) z : Nat (also named x) @@ -69,7 +69,7 @@ Also, `Z` is an alias for `X`. ⍟ I've added these definitions: - type Z + structural type Z (also named X) z : Nat (also named x) @@ -79,7 +79,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` ```ucm @@ -91,7 +91,7 @@ type X = Three Nat Nat Nat ⍟ These names already exist. You can `update` them to your new definition: - type X + structural type X (The old definition is also named Z. I'll update this name too.) x : Nat @@ -106,7 +106,7 @@ Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old ⍟ I've updated these names to your new definition: - type X + structural type X (The old definition was also named Z. I updated this name too.) x : Nat @@ -118,7 +118,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -type X = Two Nat Nat +structural type X = Two Nat Nat ``` ```ucm @@ -130,7 +130,7 @@ type X = Two Nat Nat ⍟ These names already exist. You can `update` them to your new definition: - type X + structural type X (The old definition is also named Z. I'll update this name too.) (The new definition is already named Y as well.) @@ -147,7 +147,7 @@ Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also ⍟ I've updated these names to your new definition: - type X + structural type X (The old definition was also named Z. I updated this name too.) (The new definition is already named Y as well.) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index a58ee8f14f..30f60cd2d2 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -20,434 +20,451 @@ Let's try it! 1. builtin type Any 2. Any.Any : a -> Any - 3. builtin type Boolean - 4. Boolean.not : Boolean -> Boolean - 5. bug : a -> b - 6. builtin type Bytes - 7. Bytes.++ : Bytes -> Bytes -> Bytes - 8. Bytes.at : Nat -> Bytes -> Optional Nat - 9. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) - 10. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) - 11. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) - 12. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) - 13. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) - 14. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) - 15. Bytes.drop : Nat -> Bytes -> Bytes - 16. Bytes.empty : Bytes - 17. Bytes.encodeNat16be : Nat -> Bytes - 18. Bytes.encodeNat16le : Nat -> Bytes - 19. Bytes.encodeNat32be : Nat -> Bytes - 20. Bytes.encodeNat32le : Nat -> Bytes - 21. Bytes.encodeNat64be : Nat -> Bytes - 22. Bytes.encodeNat64le : Nat -> Bytes - 23. Bytes.flatten : Bytes -> Bytes - 24. Bytes.fromBase16 : Bytes -> Either Text Bytes - 25. Bytes.fromBase32 : Bytes -> Either Text Bytes - 26. Bytes.fromBase64 : Bytes -> Either Text Bytes - 27. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 28. Bytes.fromList : [Nat] -> Bytes - 29. Bytes.size : Bytes -> Nat - 30. Bytes.take : Nat -> Bytes -> Bytes - 31. Bytes.toBase16 : Bytes -> Bytes - 32. Bytes.toBase32 : Bytes -> Bytes - 33. Bytes.toBase64 : Bytes -> Bytes - 34. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 35. Bytes.toList : Bytes -> [Nat] - 36. builtin type Char - 37. Char.fromNat : Nat -> Char - 38. Char.toNat : Char -> Nat - 39. Char.toText : Char -> Text - 40. builtin type Code - 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 42. Code.dependencies : Code -> [Term] - 43. Code.deserialize : Bytes -> Either Text Code - 44. Code.isMissing : Term ->{IO} Boolean - 45. Code.lookup : Term ->{IO} Optional Code - 46. Code.serialize : Code -> Bytes - 47. crypto.hash : HashAlgorithm -> a -> Bytes - 48. builtin type crypto.HashAlgorithm - 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 58. crypto.hmacBytes : HashAlgorithm + 3. Any.unsafeExtract : Any -> a + 4. builtin type Boolean + 5. Boolean.not : Boolean -> Boolean + 6. bug : a -> b + 7. builtin type Bytes + 8. Bytes.++ : Bytes -> Bytes -> Bytes + 9. Bytes.at : Nat -> Bytes -> Optional Nat + 10. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) + 11. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) + 12. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) + 13. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) + 14. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) + 15. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) + 16. Bytes.drop : Nat -> Bytes -> Bytes + 17. Bytes.empty : Bytes + 18. Bytes.encodeNat16be : Nat -> Bytes + 19. Bytes.encodeNat16le : Nat -> Bytes + 20. Bytes.encodeNat32be : Nat -> Bytes + 21. Bytes.encodeNat32le : Nat -> Bytes + 22. Bytes.encodeNat64be : Nat -> Bytes + 23. Bytes.encodeNat64le : Nat -> Bytes + 24. Bytes.flatten : Bytes -> Bytes + 25. Bytes.fromBase16 : Bytes -> Either Text Bytes + 26. Bytes.fromBase32 : Bytes -> Either Text Bytes + 27. Bytes.fromBase64 : Bytes -> Either Text Bytes + 28. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes + 29. Bytes.fromList : [Nat] -> Bytes + 30. Bytes.gzip.compress : Bytes -> Bytes + 31. Bytes.gzip.decompress : Bytes -> Either Text Bytes + 32. Bytes.size : Bytes -> Nat + 33. Bytes.take : Nat -> Bytes -> Bytes + 34. Bytes.toBase16 : Bytes -> Bytes + 35. Bytes.toBase32 : Bytes -> Bytes + 36. Bytes.toBase64 : Bytes -> Bytes + 37. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 38. Bytes.toList : Bytes -> [Nat] + 39. Bytes.zlib.compress : Bytes -> Bytes + 40. Bytes.zlib.decompress : Bytes -> Either Text Bytes + 41. builtin type Char + 42. Char.fromNat : Nat -> Char + 43. Char.toNat : Char -> Nat + 44. Char.toText : Char -> Text + 45. builtin type Code + 46. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 47. Code.dependencies : Code -> [Term] + 48. Code.deserialize : Bytes -> Either Text Code + 49. Code.display : Text -> Code -> Text + 50. Code.isMissing : Term ->{IO} Boolean + 51. Code.lookup : Term ->{IO} Optional Code + 52. Code.serialize : Code -> Bytes + 53. Code.validate : [(Term, Code)] ->{IO} Optional Failure + 54. crypto.hash : HashAlgorithm -> a -> Bytes + 55. builtin type crypto.HashAlgorithm + 56. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 57. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 58. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 59. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 60. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 61. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 62. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 63. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 64. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 65. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 59. Debug.watch : Text -> a -> a - 60. unique type Doc - 61. Doc.Blob : Text -> Doc - 62. Doc.Evaluate : Term -> Doc - 63. Doc.Join : [Doc] -> Doc - 64. Doc.Link : Link -> Doc - 65. Doc.Signature : Term -> Doc - 66. Doc.Source : Link -> Doc - 67. type Either a b - 68. Either.Left : a -> Either a b - 69. Either.Right : b -> Either a b - 70. ability Exception - 71. Exception.raise : Failure ->{Exception} x - 72. builtin type Float - 73. Float.* : Float -> Float -> Float - 74. Float.+ : Float -> Float -> Float - 75. Float.- : Float -> Float -> Float - 76. Float./ : Float -> Float -> Float - 77. Float.abs : Float -> Float - 78. Float.acos : Float -> Float - 79. Float.acosh : Float -> Float - 80. Float.asin : Float -> Float - 81. Float.asinh : Float -> Float - 82. Float.atan : Float -> Float - 83. Float.atan2 : Float -> Float -> Float - 84. Float.atanh : Float -> Float - 85. Float.ceiling : Float -> Int - 86. Float.cos : Float -> Float - 87. Float.cosh : Float -> Float - 88. Float.eq : Float -> Float -> Boolean - 89. Float.exp : Float -> Float - 90. Float.floor : Float -> Int - 91. Float.fromRepresentation : Nat -> Float - 92. Float.fromText : Text -> Optional Float - 93. Float.gt : Float -> Float -> Boolean - 94. Float.gteq : Float -> Float -> Boolean - 95. Float.log : Float -> Float - 96. Float.logBase : Float -> Float -> Float - 97. Float.lt : Float -> Float -> Boolean - 98. Float.lteq : Float -> Float -> Boolean - 99. Float.max : Float -> Float -> Float - 100. Float.min : Float -> Float -> Float - 101. Float.pow : Float -> Float -> Float - 102. Float.round : Float -> Int - 103. Float.sin : Float -> Float - 104. Float.sinh : Float -> Float - 105. Float.sqrt : Float -> Float - 106. Float.tan : Float -> Float - 107. Float.tanh : Float -> Float - 108. Float.toRepresentation : Float -> Nat - 109. Float.toText : Float -> Text - 110. Float.truncate : Float -> Int - 111. builtin type Int - 112. Int.* : Int -> Int -> Int - 113. Int.+ : Int -> Int -> Int - 114. Int.- : Int -> Int -> Int - 115. Int./ : Int -> Int -> Int - 116. Int.and : Int -> Int -> Int - 117. Int.complement : Int -> Int - 118. Int.eq : Int -> Int -> Boolean - 119. Int.fromRepresentation : Nat -> Int - 120. Int.fromText : Text -> Optional Int - 121. Int.gt : Int -> Int -> Boolean - 122. Int.gteq : Int -> Int -> Boolean - 123. Int.increment : Int -> Int - 124. Int.isEven : Int -> Boolean - 125. Int.isOdd : Int -> Boolean - 126. Int.leadingZeros : Int -> Nat - 127. Int.lt : Int -> Int -> Boolean - 128. Int.lteq : Int -> Int -> Boolean - 129. Int.mod : Int -> Int -> Int - 130. Int.negate : Int -> Int - 131. Int.or : Int -> Int -> Int - 132. Int.popCount : Int -> Nat - 133. Int.pow : Int -> Nat -> Int - 134. Int.shiftLeft : Int -> Nat -> Int - 135. Int.shiftRight : Int -> Nat -> Int - 136. Int.signum : Int -> Int - 137. Int.toFloat : Int -> Float - 138. Int.toRepresentation : Int -> Nat - 139. Int.toText : Int -> Text - 140. Int.trailingZeros : Int -> Nat - 141. Int.truncate0 : Int -> Nat - 142. Int.xor : Int -> Int -> Int - 143. unique type io2.BufferMode - 144. io2.BufferMode.BlockBuffering : BufferMode - 145. io2.BufferMode.LineBuffering : BufferMode - 146. io2.BufferMode.NoBuffering : BufferMode - 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 148. unique type io2.Failure - 149. io2.Failure.Failure : Type -> Text -> Any -> Failure - 150. unique type io2.FileMode - 151. io2.FileMode.Append : FileMode - 152. io2.FileMode.Read : FileMode - 153. io2.FileMode.ReadWrite : FileMode - 154. io2.FileMode.Write : FileMode - 155. builtin type io2.Handle - 156. builtin type io2.IO - 157. io2.IO.clientSocket.impl : Text + 66. Debug.watch : Text -> a -> a + 67. unique type Doc + 68. Doc.Blob : Text -> Doc + 69. Doc.Evaluate : Term -> Doc + 70. Doc.Join : [Doc] -> Doc + 71. Doc.Link : Link -> Doc + 72. Doc.Signature : Term -> Doc + 73. Doc.Source : Link -> Doc + 74. structural type Either a b + 75. Either.Left : a -> Either a b + 76. Either.Right : b -> Either a b + 77. structural ability Exception + 78. Exception.raise : Failure ->{Exception} x + 79. builtin type Float + 80. Float.* : Float -> Float -> Float + 81. Float.+ : Float -> Float -> Float + 82. Float.- : Float -> Float -> Float + 83. Float./ : Float -> Float -> Float + 84. Float.abs : Float -> Float + 85. Float.acos : Float -> Float + 86. Float.acosh : Float -> Float + 87. Float.asin : Float -> Float + 88. Float.asinh : Float -> Float + 89. Float.atan : Float -> Float + 90. Float.atan2 : Float -> Float -> Float + 91. Float.atanh : Float -> Float + 92. Float.ceiling : Float -> Int + 93. Float.cos : Float -> Float + 94. Float.cosh : Float -> Float + 95. Float.eq : Float -> Float -> Boolean + 96. Float.exp : Float -> Float + 97. Float.floor : Float -> Int + 98. Float.fromRepresentation : Nat -> Float + 99. Float.fromText : Text -> Optional Float + 100. Float.gt : Float -> Float -> Boolean + 101. Float.gteq : Float -> Float -> Boolean + 102. Float.log : Float -> Float + 103. Float.logBase : Float -> Float -> Float + 104. Float.lt : Float -> Float -> Boolean + 105. Float.lteq : Float -> Float -> Boolean + 106. Float.max : Float -> Float -> Float + 107. Float.min : Float -> Float -> Float + 108. Float.pow : Float -> Float -> Float + 109. Float.round : Float -> Int + 110. Float.sin : Float -> Float + 111. Float.sinh : Float -> Float + 112. Float.sqrt : Float -> Float + 113. Float.tan : Float -> Float + 114. Float.tanh : Float -> Float + 115. Float.toRepresentation : Float -> Nat + 116. Float.toText : Float -> Text + 117. Float.truncate : Float -> Int + 118. builtin type Int + 119. Int.* : Int -> Int -> Int + 120. Int.+ : Int -> Int -> Int + 121. Int.- : Int -> Int -> Int + 122. Int./ : Int -> Int -> Int + 123. Int.and : Int -> Int -> Int + 124. Int.complement : Int -> Int + 125. Int.eq : Int -> Int -> Boolean + 126. Int.fromRepresentation : Nat -> Int + 127. Int.fromText : Text -> Optional Int + 128. Int.gt : Int -> Int -> Boolean + 129. Int.gteq : Int -> Int -> Boolean + 130. Int.increment : Int -> Int + 131. Int.isEven : Int -> Boolean + 132. Int.isOdd : Int -> Boolean + 133. Int.leadingZeros : Int -> Nat + 134. Int.lt : Int -> Int -> Boolean + 135. Int.lteq : Int -> Int -> Boolean + 136. Int.mod : Int -> Int -> Int + 137. Int.negate : Int -> Int + 138. Int.or : Int -> Int -> Int + 139. Int.popCount : Int -> Nat + 140. Int.pow : Int -> Nat -> Int + 141. Int.shiftLeft : Int -> Nat -> Int + 142. Int.shiftRight : Int -> Nat -> Int + 143. Int.signum : Int -> Int + 144. Int.toFloat : Int -> Float + 145. Int.toRepresentation : Int -> Nat + 146. Int.toText : Int -> Text + 147. Int.trailingZeros : Int -> Nat + 148. Int.truncate0 : Int -> Nat + 149. Int.xor : Int -> Int -> Int + 150. unique type io2.BufferMode + 151. io2.BufferMode.BlockBuffering : BufferMode + 152. io2.BufferMode.LineBuffering : BufferMode + 153. io2.BufferMode.NoBuffering : BufferMode + 154. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 155. unique type io2.Failure + 156. io2.Failure.Failure : Type -> Text -> Any -> Failure + 157. unique type io2.FileMode + 158. io2.FileMode.Append : FileMode + 159. io2.FileMode.Read : FileMode + 160. io2.FileMode.ReadWrite : FileMode + 161. io2.FileMode.Write : FileMode + 162. builtin type io2.Handle + 163. builtin type io2.IO + 164. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 160. io2.IO.createDirectory.impl : Text + 165. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 166. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 167. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 161. io2.IO.createTempDirectory.impl : Text + 168. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 163. io2.IO.directoryContents.impl : Text + 169. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 170. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 164. io2.IO.fileExists.impl : Text + 171. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 166. io2.IO.getBuffering.impl : Handle + 172. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 173. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 167. io2.IO.getBytes.impl : Handle + 174. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 168. io2.IO.getCurrentDirectory.impl : '{IO} Either + 175. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 171. io2.IO.getFileTimestamp.impl : Text + 176. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 177. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 178. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 174. io2.IO.handlePosition.impl : Handle + 179. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 180. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 181. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 175. io2.IO.isDirectory.impl : Text + 182. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 176. io2.IO.isFileEOF.impl : Handle + 183. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 177. io2.IO.isFileOpen.impl : Handle + 184. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isSeekable.impl : Handle + 185. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 181. io2.IO.openFile.impl : Text + 186. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 187. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 188. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 182. io2.IO.putBytes.impl : Handle + 189. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 183. io2.IO.removeDirectory.impl : Text + 190. io2.IO.ref : a ->{IO} Ref {IO} a + 191. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 184. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 185. io2.IO.renameDirectory.impl : Text + 192. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 193. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 186. io2.IO.renameFile.impl : Text + 194. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 187. io2.IO.seekHandle.impl : Handle + 195. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 188. io2.IO.serverSocket.impl : Optional Text + 196. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 189. io2.IO.setBuffering.impl : Handle + 197. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 190. io2.IO.setCurrentDirectory.impl : Text + 198. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 191. io2.IO.socketAccept.impl : Socket + 199. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 192. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 193. io2.IO.socketReceive.impl : Socket + 200. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 201. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 194. io2.IO.socketSend.impl : Socket + 202. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 195. io2.IO.stdHandle : StdHandle -> Handle - 196. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 197. unique type io2.IOError - 198. io2.IOError.AlreadyExists : IOError - 199. io2.IOError.EOF : IOError - 200. io2.IOError.IllegalOperation : IOError - 201. io2.IOError.NoSuchThing : IOError - 202. io2.IOError.PermissionDenied : IOError - 203. io2.IOError.ResourceBusy : IOError - 204. io2.IOError.ResourceExhausted : IOError - 205. io2.IOError.UserError : IOError - 206. unique type io2.IOFailure - 207. builtin type io2.MVar - 208. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 209. io2.MVar.new : a ->{IO} MVar a - 210. io2.MVar.newEmpty : '{IO} MVar a - 211. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 212. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 213. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 214. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 215. io2.MVar.tryPut.impl : MVar a + 203. io2.IO.stdHandle : StdHandle -> Handle + 204. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 205. io2.IO.systemTimeMicroseconds : '{IO} Int + 206. unique type io2.IOError + 207. io2.IOError.AlreadyExists : IOError + 208. io2.IOError.EOF : IOError + 209. io2.IOError.IllegalOperation : IOError + 210. io2.IOError.NoSuchThing : IOError + 211. io2.IOError.PermissionDenied : IOError + 212. io2.IOError.ResourceBusy : IOError + 213. io2.IOError.ResourceExhausted : IOError + 214. io2.IOError.UserError : IOError + 215. unique type io2.IOFailure + 216. builtin type io2.MVar + 217. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 218. io2.MVar.new : a ->{IO} MVar a + 219. io2.MVar.newEmpty : '{IO} MVar a + 220. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 221. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 222. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 223. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 224. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 216. io2.MVar.tryRead.impl : MVar a + 225. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 217. io2.MVar.tryTake : MVar a ->{IO} Optional a - 218. unique type io2.SeekMode - 219. io2.SeekMode.AbsoluteSeek : SeekMode - 220. io2.SeekMode.RelativeSeek : SeekMode - 221. io2.SeekMode.SeekFromEnd : SeekMode - 222. builtin type io2.Socket - 223. unique type io2.StdHandle - 224. io2.StdHandle.StdErr : StdHandle - 225. io2.StdHandle.StdIn : StdHandle - 226. io2.StdHandle.StdOut : StdHandle - 227. builtin type io2.STM - 228. io2.STM.atomically : '{STM} a ->{IO} a - 229. io2.STM.retry : '{STM} a - 230. builtin type io2.ThreadId - 231. builtin type io2.Tls - 232. builtin type io2.Tls.Cipher - 233. builtin type io2.Tls.ClientConfig - 234. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 226. io2.MVar.tryTake : MVar a ->{IO} Optional a + 227. unique type io2.SeekMode + 228. io2.SeekMode.AbsoluteSeek : SeekMode + 229. io2.SeekMode.RelativeSeek : SeekMode + 230. io2.SeekMode.SeekFromEnd : SeekMode + 231. builtin type io2.Socket + 232. unique type io2.StdHandle + 233. io2.StdHandle.StdErr : StdHandle + 234. io2.StdHandle.StdIn : StdHandle + 235. io2.StdHandle.StdOut : StdHandle + 236. builtin type io2.STM + 237. io2.STM.atomically : '{STM} a ->{IO} a + 238. io2.STM.retry : '{STM} a + 239. builtin type io2.ThreadId + 240. builtin type io2.Tls + 241. builtin type io2.Tls.Cipher + 242. builtin type io2.Tls.ClientConfig + 243. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 235. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 244. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 236. io2.Tls.ClientConfig.default : Text + 245. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 237. io2.Tls.ClientConfig.versions.set : [Version] + 246. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 238. io2.Tls.decodeCert.impl : Bytes + 247. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 239. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 240. io2.Tls.encodeCert : SignedCert -> Bytes - 241. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 242. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 243. io2.Tls.newClient.impl : ClientConfig + 248. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 249. io2.Tls.encodeCert : SignedCert -> Bytes + 250. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 251. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 252. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 244. io2.Tls.newServer.impl : ServerConfig + 253. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 245. builtin type io2.Tls.PrivateKey - 246. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 247. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 248. builtin type io2.Tls.ServerConfig - 249. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 254. builtin type io2.Tls.PrivateKey + 255. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 256. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 257. builtin type io2.Tls.ServerConfig + 258. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 250. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 259. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 251. io2.Tls.ServerConfig.default : [SignedCert] + 260. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 252. io2.Tls.ServerConfig.versions.set : [Version] + 261. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 253. builtin type io2.Tls.SignedCert - 254. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 255. builtin type io2.Tls.Version - 256. unique type io2.TlsFailure - 257. builtin type io2.TVar - 258. io2.TVar.new : a ->{STM} TVar a - 259. io2.TVar.newIO : a ->{IO} TVar a - 260. io2.TVar.read : TVar a ->{STM} a - 261. io2.TVar.readIO : TVar a ->{IO} a - 262. io2.TVar.swap : TVar a -> a ->{STM} a - 263. io2.TVar.write : TVar a -> a ->{STM} () - 264. unique type IsPropagated - 265. IsPropagated.IsPropagated : IsPropagated - 266. unique type IsTest - 267. IsTest.IsTest : IsTest - 268. unique type Link - 269. builtin type Link.Term - 270. Link.Term : Term -> Link - 271. builtin type Link.Type - 272. Link.Type : Type -> Link - 273. builtin type List - 274. List.++ : [a] -> [a] -> [a] - 275. List.+: : a -> [a] -> [a] - 276. List.:+ : [a] -> a -> [a] - 277. List.at : Nat -> [a] -> Optional a - 278. List.cons : a -> [a] -> [a] - 279. List.drop : Nat -> [a] -> [a] - 280. List.empty : [a] - 281. List.size : [a] -> Nat - 282. List.snoc : [a] -> a -> [a] - 283. List.take : Nat -> [a] -> [a] - 284. metadata.isPropagated : IsPropagated - 285. metadata.isTest : IsTest - 286. builtin type Nat - 287. Nat.* : Nat -> Nat -> Nat - 288. Nat.+ : Nat -> Nat -> Nat - 289. Nat./ : Nat -> Nat -> Nat - 290. Nat.and : Nat -> Nat -> Nat - 291. Nat.complement : Nat -> Nat - 292. Nat.drop : Nat -> Nat -> Nat - 293. Nat.eq : Nat -> Nat -> Boolean - 294. Nat.fromText : Text -> Optional Nat - 295. Nat.gt : Nat -> Nat -> Boolean - 296. Nat.gteq : Nat -> Nat -> Boolean - 297. Nat.increment : Nat -> Nat - 298. Nat.isEven : Nat -> Boolean - 299. Nat.isOdd : Nat -> Boolean - 300. Nat.leadingZeros : Nat -> Nat - 301. Nat.lt : Nat -> Nat -> Boolean - 302. Nat.lteq : Nat -> Nat -> Boolean - 303. Nat.mod : Nat -> Nat -> Nat - 304. Nat.or : Nat -> Nat -> Nat - 305. Nat.popCount : Nat -> Nat - 306. Nat.pow : Nat -> Nat -> Nat - 307. Nat.shiftLeft : Nat -> Nat -> Nat - 308. Nat.shiftRight : Nat -> Nat -> Nat - 309. Nat.sub : Nat -> Nat -> Int - 310. Nat.toFloat : Nat -> Float - 311. Nat.toInt : Nat -> Int - 312. Nat.toText : Nat -> Text - 313. Nat.trailingZeros : Nat -> Nat - 314. Nat.xor : Nat -> Nat -> Nat - 315. type Optional a - 316. Optional.None : Optional a - 317. Optional.Some : a -> Optional a - 318. builtin type Request - 319. type SeqView a b - 320. SeqView.VElem : a -> b -> SeqView a b - 321. SeqView.VEmpty : SeqView a b - 322. unique type Test.Result - 323. Test.Result.Fail : Text -> Result - 324. Test.Result.Ok : Text -> Result - 325. builtin type Text - 326. Text.!= : Text -> Text -> Boolean - 327. Text.++ : Text -> Text -> Text - 328. Text.drop : Nat -> Text -> Text - 329. Text.empty : Text - 330. Text.eq : Text -> Text -> Boolean - 331. Text.fromCharList : [Char] -> Text - 332. Text.fromUtf8.impl : Bytes -> Either Failure Text - 333. Text.gt : Text -> Text -> Boolean - 334. Text.gteq : Text -> Text -> Boolean - 335. Text.lt : Text -> Text -> Boolean - 336. Text.lteq : Text -> Text -> Boolean - 337. Text.repeat : Nat -> Text -> Text - 338. Text.size : Text -> Nat - 339. Text.take : Nat -> Text -> Text - 340. Text.toCharList : Text -> [Char] - 341. Text.toUtf8 : Text -> Bytes - 342. Text.uncons : Text -> Optional (Char, Text) - 343. Text.unsnoc : Text -> Optional (Text, Char) - 344. todo : a -> b - 345. type Tuple a b - 346. Tuple.Cons : a -> b -> Tuple a b - 347. type Unit - 348. Unit.Unit : () - 349. Universal.< : a -> a -> Boolean - 350. Universal.<= : a -> a -> Boolean - 351. Universal.== : a -> a -> Boolean - 352. Universal.> : a -> a -> Boolean - 353. Universal.>= : a -> a -> Boolean - 354. Universal.compare : a -> a -> Int - 355. builtin type Value - 356. Value.dependencies : Value -> [Term] - 357. Value.deserialize : Bytes -> Either Text Value - 358. Value.load : Value ->{IO} Either [Term] a - 359. Value.serialize : Value -> Bytes - 360. Value.value : a -> Value + 262. builtin type io2.Tls.SignedCert + 263. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 264. builtin type io2.Tls.Version + 265. unique type io2.TlsFailure + 266. builtin type io2.TVar + 267. io2.TVar.new : a ->{STM} TVar a + 268. io2.TVar.newIO : a ->{IO} TVar a + 269. io2.TVar.read : TVar a ->{STM} a + 270. io2.TVar.readIO : TVar a ->{IO} a + 271. io2.TVar.swap : TVar a -> a ->{STM} a + 272. io2.TVar.write : TVar a -> a ->{STM} () + 273. unique type IsPropagated + 274. IsPropagated.IsPropagated : IsPropagated + 275. unique type IsTest + 276. IsTest.IsTest : IsTest + 277. unique type Link + 278. builtin type Link.Term + 279. Link.Term : Term -> Link + 280. Link.Term.toText : Term -> Text + 281. builtin type Link.Type + 282. Link.Type : Type -> Link + 283. builtin type List + 284. List.++ : [a] -> [a] -> [a] + 285. List.+: : a -> [a] -> [a] + 286. List.:+ : [a] -> a -> [a] + 287. List.at : Nat -> [a] -> Optional a + 288. List.cons : a -> [a] -> [a] + 289. List.drop : Nat -> [a] -> [a] + 290. List.empty : [a] + 291. List.size : [a] -> Nat + 292. List.snoc : [a] -> a -> [a] + 293. List.take : Nat -> [a] -> [a] + 294. metadata.isPropagated : IsPropagated + 295. metadata.isTest : IsTest + 296. builtin type Nat + 297. Nat.* : Nat -> Nat -> Nat + 298. Nat.+ : Nat -> Nat -> Nat + 299. Nat./ : Nat -> Nat -> Nat + 300. Nat.and : Nat -> Nat -> Nat + 301. Nat.complement : Nat -> Nat + 302. Nat.drop : Nat -> Nat -> Nat + 303. Nat.eq : Nat -> Nat -> Boolean + 304. Nat.fromText : Text -> Optional Nat + 305. Nat.gt : Nat -> Nat -> Boolean + 306. Nat.gteq : Nat -> Nat -> Boolean + 307. Nat.increment : Nat -> Nat + 308. Nat.isEven : Nat -> Boolean + 309. Nat.isOdd : Nat -> Boolean + 310. Nat.leadingZeros : Nat -> Nat + 311. Nat.lt : Nat -> Nat -> Boolean + 312. Nat.lteq : Nat -> Nat -> Boolean + 313. Nat.mod : Nat -> Nat -> Nat + 314. Nat.or : Nat -> Nat -> Nat + 315. Nat.popCount : Nat -> Nat + 316. Nat.pow : Nat -> Nat -> Nat + 317. Nat.shiftLeft : Nat -> Nat -> Nat + 318. Nat.shiftRight : Nat -> Nat -> Nat + 319. Nat.sub : Nat -> Nat -> Int + 320. Nat.toFloat : Nat -> Float + 321. Nat.toInt : Nat -> Int + 322. Nat.toText : Nat -> Text + 323. Nat.trailingZeros : Nat -> Nat + 324. Nat.xor : Nat -> Nat -> Nat + 325. structural type Optional a + 326. Optional.None : Optional a + 327. Optional.Some : a -> Optional a + 328. builtin type Ref + 329. Ref.read : Ref g a ->{g} a + 330. Ref.write : Ref g a -> a ->{g} () + 331. builtin type Request + 332. builtin type Scope + 333. Scope.ref : a ->{Scope s} Ref {Scope s} a + 334. Scope.run : (βˆ€ s. '{g, Scope s} r) ->{g} r + 335. structural type SeqView a b + 336. SeqView.VElem : a -> b -> SeqView a b + 337. SeqView.VEmpty : SeqView a b + 338. unique type Test.Result + 339. Test.Result.Fail : Text -> Result + 340. Test.Result.Ok : Text -> Result + 341. builtin type Text + 342. Text.!= : Text -> Text -> Boolean + 343. Text.++ : Text -> Text -> Text + 344. Text.drop : Nat -> Text -> Text + 345. Text.empty : Text + 346. Text.eq : Text -> Text -> Boolean + 347. Text.fromCharList : [Char] -> Text + 348. Text.fromUtf8.impl : Bytes -> Either Failure Text + 349. Text.gt : Text -> Text -> Boolean + 350. Text.gteq : Text -> Text -> Boolean + 351. Text.lt : Text -> Text -> Boolean + 352. Text.lteq : Text -> Text -> Boolean + 353. Text.repeat : Nat -> Text -> Text + 354. Text.size : Text -> Nat + 355. Text.take : Nat -> Text -> Text + 356. Text.toCharList : Text -> [Char] + 357. Text.toUtf8 : Text -> Bytes + 358. Text.uncons : Text -> Optional (Char, Text) + 359. Text.unsnoc : Text -> Optional (Text, Char) + 360. todo : a -> b + 361. structural type Tuple a b + 362. Tuple.Cons : a -> b -> Tuple a b + 363. structural type Unit + 364. Unit.Unit : () + 365. Universal.< : a -> a -> Boolean + 366. Universal.<= : a -> a -> Boolean + 367. Universal.== : a -> a -> Boolean + 368. Universal.> : a -> a -> Boolean + 369. Universal.>= : a -> a -> Boolean + 370. Universal.compare : a -> a -> Int + 371. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 372. builtin type Value + 373. Value.dependencies : Value -> [Term] + 374. Value.deserialize : Bytes -> Either Text Value + 375. Value.load : Value ->{IO} Either [Term] a + 376. Value.serialize : Value -> Bytes + 377. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -456,17 +473,17 @@ Let's try it! Added definitions: - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.cosh : Float -> Float + 2. Float.eq : Float -> Float -> Boolean + 3. Float.exp : Float -> Float + 4. Float.floor : Float -> Int + 5. Float.fromRepresentation : Nat -> Float + 6. Float.fromText : Text -> Optional Float + 7. Float.gt : Float -> Float -> Boolean + 8. Float.gteq : Float -> Float -> Boolean + 9. Float.log : Float -> Float + 10. Float.logBase : Float -> Float -> Float + 11. Float.lt : Float -> Float -> Boolean Tip: You can use `undo` or `reflog` to undo this change. @@ -526,17 +543,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.cosh : Float -> Float + 2. Float.eq : Float -> Float -> Boolean + 3. Float.exp : Float -> Float + 4. Float.floor : Float -> Int + 5. Float.fromRepresentation : Nat -> Float + 6. Float.fromText : Text -> Optional Float + 7. Float.gt : Float -> Float -> Boolean + 8. Float.gteq : Float -> Float -> Boolean + 9. Float.log : Float -> Float + 10. Float.logBase : Float -> Float -> Float + 11. Float.lt : Float -> Float -> Boolean 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/any-extract.md b/unison-src/transcripts/any-extract.md new file mode 100644 index 0000000000..6463f11472 --- /dev/null +++ b/unison-src/transcripts/any-extract.md @@ -0,0 +1,25 @@ +# Unit tests for Any.unsafeExtract + +```ucm:hide +.> builtins.merge +.> cd builtin +.> load unison-src/transcripts-using-base/base.u +.> add +``` + +Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. + +```unison + +test> Any.unsafeExtract.works = + use Nat != + checks [1 == Any.unsafeExtract (Any 1), + not (1 == Any.unsafeExtract (Any 2)), + (Some 1) == Any.unsafeExtract (Any (Some 1)) + ] +``` + +```ucm +.> add +``` + diff --git a/unison-src/transcripts/any-extract.output.md b/unison-src/transcripts/any-extract.output.md new file mode 100644 index 0000000000..1fe1252014 --- /dev/null +++ b/unison-src/transcripts/any-extract.output.md @@ -0,0 +1,39 @@ +# Unit tests for Any.unsafeExtract + +Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. + +```unison +test> Any.unsafeExtract.works = + use Nat != + checks [1 == Any.unsafeExtract (Any 1), + not (1 == Any.unsafeExtract (Any 2)), + (Some 1) == Any.unsafeExtract (Any (Some 1)) + ] +``` + +```ucm + + 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`: + + Any.unsafeExtract.works : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | checks [1 == Any.unsafeExtract (Any 1), + + βœ… Passed Passed + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + Any.unsafeExtract.works : [Result] + +``` diff --git a/unison-src/transcripts/blocks.md b/unison-src/transcripts/blocks.md index c7f4277090..f767391012 100644 --- a/unison-src/transcripts/blocks.md +++ b/unison-src/transcripts/blocks.md @@ -125,7 +125,7 @@ Just don't try to run it as it's an infinite loop! The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: ```unison:error -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -139,7 +139,7 @@ ex n = For instance, this works fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -153,7 +153,7 @@ ex n = For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -166,7 +166,7 @@ ex n = This is actually parsed as if you moved `zap` after the cycle it find itself a part of: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = diff --git a/unison-src/transcripts/blocks.output.md b/unison-src/transcripts/blocks.output.md index 3c82472504..28628efede 100644 --- a/unison-src/transcripts/blocks.output.md +++ b/unison-src/transcripts/blocks.output.md @@ -242,7 +242,7 @@ Just don't try to run it as it's an infinite loop! The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -264,7 +264,7 @@ ex n = For instance, this works fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -281,7 +281,7 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} Nat ``` @@ -290,7 +290,7 @@ ex n = For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -308,14 +308,14 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} r ``` This is actually parsed as if you moved `zap` after the cycle it find itself a part of: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -333,7 +333,7 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} r ``` diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md index b6ec787738..1dfe955f0a 100644 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ b/unison-src/transcripts/bug-strange-closure.output.md @@ -88,7 +88,7 @@ We can display the guide before and after adding it to the codebase: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -96,7 +96,7 @@ We can display the guide before and after adding it to the codebase: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -289,7 +289,7 @@ We can display the guide before and after adding it to the codebase: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -297,7 +297,7 @@ We can display the guide before and after adding it to the codebase: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -496,7 +496,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -504,7 +504,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -690,7 +690,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -698,7 +698,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -2077,10 +2077,9 @@ rendered = Pretty.get (docFormatConsole doc.guide) (Term.Term (Any '(f x -> - f - x - Nat.+ sqr - 1))))), + f x + Nat.+ sqr + 1))))), !Lit (Right (Plain "-")), diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 9ec2694f10..5b02fc736a 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -10,15 +10,15 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace .tmp> ls builtin 1. Any (builtin type) - 2. Any/ (1 definition) + 2. Any/ (2 definitions) 3. Boolean (builtin type) 4. Boolean/ (1 definition) 5. Bytes (builtin type) - 6. Bytes/ (29 definitions) + 6. Bytes/ (33 definitions) 7. Char (builtin type) 8. Char/ (3 definitions) 9. Code (builtin type) - 10. Code/ (6 definitions) + 10. Code/ (8 definitions) 11. Debug/ (1 definition) 12. Doc (type) 13. Doc/ (6 definitions) @@ -35,30 +35,35 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 24. IsTest (type) 25. IsTest/ (1 definition) 26. Link (type) - 27. Link/ (4 definitions) + 27. Link/ (5 definitions) 28. List (builtin type) 29. List/ (10 definitions) 30. Nat (builtin type) 31. Nat/ (28 definitions) 32. Optional (type) 33. Optional/ (2 definitions) - 34. Request (builtin type) - 35. SeqView (type) - 36. SeqView/ (2 definitions) - 37. Test/ (3 definitions) - 38. Text (builtin type) - 39. Text/ (18 definitions) - 40. Tuple (type) - 41. Tuple/ (1 definition) - 42. Unit (type) - 43. Unit/ (1 definition) - 44. Universal/ (6 definitions) - 45. Value (builtin type) - 46. Value/ (5 definitions) - 47. bug (a -> b) - 48. crypto/ (12 definitions) - 49. io2/ (121 definitions) - 50. metadata/ (2 definitions) - 51. todo (a -> b) + 34. Ref (builtin type) + 35. Ref/ (2 definitions) + 36. Request (builtin type) + 37. Scope (builtin type) + 38. Scope/ (2 definitions) + 39. SeqView (type) + 40. SeqView/ (2 definitions) + 41. Test/ (3 definitions) + 42. Text (builtin type) + 43. Text/ (18 definitions) + 44. Tuple (type) + 45. Tuple/ (1 definition) + 46. Unit (type) + 47. Unit/ (1 definition) + 48. Universal/ (6 definitions) + 49. Value (builtin type) + 50. Value/ (5 definitions) + 51. bug (a -> b) + 52. crypto/ (12 definitions) + 53. io2/ (123 definitions) + 54. metadata/ (2 definitions) + 55. todo (a -> b) + 56. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md index 8352af1586..d1bebbb37d 100644 --- a/unison-src/transcripts/builtins.md +++ b/unison-src/transcripts/builtins.md @@ -227,6 +227,27 @@ test> Bytes.tests.at = Bytes.at 0 bs == Some 77, Bytes.at 99 bs == None ] + +test> Bytes.tests.compression = + roundTrip b = + (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) + && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) + + isLeft = cases + Left _ -> true + Right _ -> false + + checks [ + roundTrip 0xs2093487509823745709827345789023457892345, + roundTrip 0xs00000000000000000000000000000000000000000000, + roundTrip 0xs, + roundTrip 0xs11111111111111111111111111, + roundTrip 0xsffffffffffffffffffffffffffffff, + roundTrip 0xs222222222fffffffffffffffffffffffffffffff, + -- these fail due to bad checksums and/or headers + isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), + isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) + ] ``` ```ucm:hide diff --git a/unison-src/transcripts/builtins.output.md b/unison-src/transcripts/builtins.output.md index b83798518a..416b1f1ccf 100644 --- a/unison-src/transcripts/builtins.output.md +++ b/unison-src/transcripts/builtins.output.md @@ -204,6 +204,27 @@ test> Bytes.tests.at = Bytes.at 0 bs == Some 77, Bytes.at 99 bs == None ] + +test> Bytes.tests.compression = + roundTrip b = + (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) + && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) + + isLeft = cases + Left _ -> true + Right _ -> false + + checks [ + roundTrip 0xs2093487509823745709827345789023457892345, + roundTrip 0xs00000000000000000000000000000000000000000000, + roundTrip 0xs, + roundTrip 0xs11111111111111111111111111, + roundTrip 0xsffffffffffffffffffffffffffffff, + roundTrip 0xs222222222fffffffffffffffffffffffffffffff, + -- these fail due to bad checksums and/or headers + isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), + isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) + ] ``` ## `Any` functions @@ -257,6 +278,7 @@ Now that all the tests have been added to the codebase, let's view the test repo β—‰ Boolean.tests.notTable Passed β—‰ Boolean.tests.orTable Passed β—‰ Bytes.tests.at Passed + β—‰ Bytes.tests.compression Passed β—‰ Int.tests.arithmetic Passed β—‰ Int.tests.bitTwiddling Passed β—‰ Int.tests.conversions Passed @@ -267,7 +289,7 @@ Now that all the tests have been added to the codebase, let's view the test repo β—‰ Text.tests.repeat Passed β—‰ Text.tests.takeDropAppend Passed - βœ… 15 test(s) passing + βœ… 16 test(s) passing Tip: Use view Any.test1 to view the source of a test. diff --git a/unison-src/transcripts/command-replace.md b/unison-src/transcripts/command-replace.md index 2117e67851..1e584529cd 100644 --- a/unison-src/transcripts/command-replace.md +++ b/unison-src/transcripts/command-replace.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm diff --git a/unison-src/transcripts/command-replace.output.md b/unison-src/transcripts/command-replace.output.md index 8957f570e3..84f905e1e8 100644 --- a/unison-src/transcripts/command-replace.output.md +++ b/unison-src/transcripts/command-replace.output.md @@ -6,8 +6,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm @@ -18,8 +18,8 @@ type Y = Two Nat Nat ⍟ These new definitions are ok to `add`: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -31,8 +31,8 @@ type Y = Two Nat Nat ⍟ I've added these definitions: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -57,10 +57,10 @@ Test that replace works with types .scratch> find - 1. type X + 1. structural type X 2. x : Nat 3. X.One : Nat -> Nat -> X - 4. type Y + 4. structural type Y 5. y : Nat 6. Y.Two : Nat -> Nat -> X @@ -77,7 +77,7 @@ Test that replace works with types .scratch> view X - type X = One Nat Nat + structural type X = One Nat Nat ``` Try with a type/term mismatch diff --git a/unison-src/transcripts/delete.md b/unison-src/transcripts/delete.md index 4fcf029d5f..b4a8b01ecf 100644 --- a/unison-src/transcripts/delete.md +++ b/unison-src/transcripts/delete.md @@ -18,7 +18,7 @@ unambiguous type. ```unison:hide foo = 1 -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -60,7 +60,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison:hide -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -68,7 +68,7 @@ type Foo = Foo Nat ``` ```unison:hide -type Foo = Foo Boolean +structural type Foo = Foo Boolean ``` ```ucm @@ -88,7 +88,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison:hide foo = 1 -type foo = Foo Nat +structural type foo = Foo Nat ``` ```ucm diff --git a/unison-src/transcripts/delete.output.md b/unison-src/transcripts/delete.output.md index 45fba4a36e..7570d774f5 100644 --- a/unison-src/transcripts/delete.output.md +++ b/unison-src/transcripts/delete.output.md @@ -18,7 +18,7 @@ unambiguous type. ```unison foo = 1 -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -26,7 +26,7 @@ type Foo = Foo Nat ⍟ I've added these definitions: - type Foo + structural type Foo foo : Nat .> delete foo @@ -41,7 +41,7 @@ type Foo = Foo Nat Removed definitions: - 1. type Foo + 1. structural type Foo Tip: You can use `undo` or `reflog` to undo this change. @@ -128,7 +128,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -136,11 +136,11 @@ type Foo = Foo Nat ⍟ I've added these definitions: - type Foo + structural type Foo ``` ```unison -type Foo = Foo Boolean +structural type Foo = Foo Boolean ``` ```ucm @@ -148,7 +148,7 @@ type Foo = Foo Boolean ⍟ I've added these definitions: - type Foo + structural type Foo .a> merge .b @@ -157,12 +157,12 @@ type Foo = Foo Boolean New name conflicts: - 1. type Foo#d97e0jhkmd + 1. structural type Foo#d97e0jhkmd ↓ - 2. β”Œ type Foo#d97e0jhkmd + 2. β”Œ structural type Foo#d97e0jhkmd - 3. β”” type Foo#gq9inhvg9h + 3. β”” structural type Foo#gq9inhvg9h 4. Foo.Foo#d97e0jhkmd#0 : Nat -> Foo#d97e0jhkmd @@ -181,7 +181,7 @@ type Foo = Foo Boolean Removed definitions: - 1. type a.Foo#d97e0jhkmd + 1. structural type a.Foo#d97e0jhkmd Name changes: @@ -212,7 +212,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison foo = 1 -type foo = Foo Nat +structural type foo = Foo Nat ``` ```ucm @@ -220,7 +220,7 @@ type foo = Foo Nat ⍟ I've added these definitions: - type foo + structural type foo foo : Nat ``` @@ -229,7 +229,7 @@ type foo = Foo Nat Removed definitions: - 1. type foo + 1. structural type foo 2. foo : Nat Tip: You can use `undo` or `reflog` to undo this change. diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.md b/unison-src/transcripts/dependents-dependencies-debugfile.md index 0bebc6f1cb..46ffce8d30 100644 --- a/unison-src/transcripts/dependents-dependencies-debugfile.md +++ b/unison-src/transcripts/dependents-dependencies-debugfile.md @@ -7,12 +7,12 @@ I can use `debug.file` to see the hashes of the last typechecked file. Given this .u file: ```unison:hide -type outside.A = A Nat outside.B -type outside.B = B Int +structural type outside.A = A Nat outside.B +structural type outside.B = B Int outside.c = 3 outside.d = c < (p + 1) -type inside.M = M outside.A +structural type inside.M = M outside.A inside.p = c inside.q x = x + p * p inside.r = d @@ -35,4 +35,4 @@ But wait, there's more. I can check the dependencies and dependents of a defini .> ``` -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the type that provided the constructor. +We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.output.md b/unison-src/transcripts/dependents-dependencies-debugfile.output.md index 2ee6390d5c..63b00362b3 100644 --- a/unison-src/transcripts/dependents-dependencies-debugfile.output.md +++ b/unison-src/transcripts/dependents-dependencies-debugfile.output.md @@ -3,12 +3,12 @@ I can use `debug.file` to see the hashes of the last typechecked file. Given this .u file: ```unison -type outside.A = A Nat outside.B -type outside.B = B Int +structural type outside.A = A Nat outside.B +structural type outside.B = B Int outside.c = 3 outside.d = c < (p + 1) -type inside.M = M outside.A +structural type inside.M = M outside.A inside.p = c inside.q x = x + p * p inside.r = d @@ -36,9 +36,9 @@ But wait, there's more. I can check the dependencies and dependents of a defini ⍟ I've added these definitions: - type inside.M - type outside.A - type outside.B + structural type inside.M + structural type outside.A + structural type outside.B inside.p : Nat inside.q : Nat -> Nat inside.r : Boolean @@ -90,4 +90,4 @@ But wait, there's more. I can check the dependencies and dependents of a defini 1. #im2kiu2hmn inside.r ``` -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the type that provided the constructor. +We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/diff.md b/unison-src/transcripts/diff.md index 5846af90c1..1f31db2a84 100644 --- a/unison-src/transcripts/diff.md +++ b/unison-src/transcripts/diff.md @@ -40,8 +40,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -type A a = A Nat -ability X a1 a2 where x : Nat +structural type A a = A Nat +structural ability X a1 a2 where x : Nat ``` ```ucm diff --git a/unison-src/transcripts/diff.output.md b/unison-src/transcripts/diff.output.md index cda20f1fcb..9cec95d7f2 100644 --- a/unison-src/transcripts/diff.output.md +++ b/unison-src/transcripts/diff.output.md @@ -105,8 +105,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -type A a = A Nat -ability X a1 a2 where x : Nat +structural type A a = A Nat +structural ability X a1 a2 where x : Nat ``` ```ucm @@ -116,8 +116,8 @@ ability X a1 a2 where x : Nat ⍟ I've added these definitions: - type A a - ability X a1 a2 + structural type A a + structural ability X a1 a2 b : Nat bdependent : Nat c : Nat @@ -155,8 +155,8 @@ Here's what we've done so far: Added definitions: - 1. type A a - 2. ability X a1 a2 + 1. structural type A a + 2. structural ability X a1 a2 3. A.A : Nat -> A a 4. X.x : {X a1 a2} Nat 5. b : Nat diff --git a/unison-src/transcripts/docs.md b/unison-src/transcripts/docs.md index 0ce76d7bab..ccb78f12bc 100644 --- a/unison-src/transcripts/docs.md +++ b/unison-src/transcripts/docs.md @@ -10,7 +10,7 @@ Unison documentation is written in Unison. Documentation is a value of the follo .> view builtin.Doc ``` -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of type `Doc` can be created via syntax like: +You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: ```unison use .builtin diff --git a/unison-src/transcripts/docs.output.md b/unison-src/transcripts/docs.output.md index f4d9d2adb0..a78489a956 100644 --- a/unison-src/transcripts/docs.output.md +++ b/unison-src/transcripts/docs.output.md @@ -14,7 +14,7 @@ Unison documentation is written in Unison. Documentation is a value of the follo | Evaluate Term ``` -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of type `Doc` can be created via syntax like: +You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: ```unison use .builtin diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 27574aefb3..b286008b8d 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (360 definitions) + 1. builtin/ (377 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (528 definitions) + 1. builtin/ (545 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/fix-2258-if-as-list-element.md new file mode 100644 index 0000000000..fbf9cc93dd --- /dev/null +++ b/unison-src/transcripts/fix-2258-if-as-list-element.md @@ -0,0 +1,66 @@ +Tests that `if` statements can appear as list and tuple elements. + +```ucm:hide +.> builtins.merge +``` + +```unison:hide +> [ if true then 1 else 0 ] + +> [ if true then 1 else 0, 1] + +> [1, if true then 1 else 0] + +> (if true then 1 else 0, 0) + +> (0, if true then 1 else 0) + +> (1) + +> (1,2) + +> (1,2,3) + +> [1,2,3] + +> [] + +> [1] + +> [1,2] + +> [1,2,3] + +> [ + 1, + 2, + 3 + ] + +> [ + 1, + 2, + 3,] + +> (1,2,3,) + +> (1, + 2,) + +structural ability Zoot where zoot : () + +Zoot.handler : Request {Zoot} a -> a +Zoot.handler = cases + { a } -> a + { zoot -> k } -> handle !k with Zoot.handler + +fst = cases (x,_) -> x + +> List.size + [ if true then (x y -> y) + else handle (x y -> x) with fst (Zoot.handler, 42), + cases a, b -> a Nat.+ b, -- multi-arg cases lambda + cases x, y -> x Nat.+ y + ] +``` + diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md new file mode 100644 index 0000000000..50c28c0046 --- /dev/null +++ b/unison-src/transcripts/fix-2258-if-as-list-element.output.md @@ -0,0 +1,62 @@ +Tests that `if` statements can appear as list and tuple elements. + +```unison +> [ if true then 1 else 0 ] + +> [ if true then 1 else 0, 1] + +> [1, if true then 1 else 0] + +> (if true then 1 else 0, 0) + +> (0, if true then 1 else 0) + +> (1) + +> (1,2) + +> (1,2,3) + +> [1,2,3] + +> [] + +> [1] + +> [1,2] + +> [1,2,3] + +> [ + 1, + 2, + 3 + ] + +> [ + 1, + 2, + 3,] + +> (1,2,3,) + +> (1, + 2,) + +structural ability Zoot where zoot : () + +Zoot.handler : Request {Zoot} a -> a +Zoot.handler = cases + { a } -> a + { zoot -> k } -> handle !k with Zoot.handler + +fst = cases (x,_) -> x + +> List.size + [ if true then (x y -> y) + else handle (x y -> x) with fst (Zoot.handler, 42), + cases a, b -> a Nat.+ b, -- multi-arg cases lambda + cases x, y -> x Nat.+ y + ] +``` + diff --git a/unison-src/transcripts/fix1578.md b/unison-src/transcripts/fix1578.md index cf1a35e154..7e825348d4 100644 --- a/unison-src/transcripts/fix1578.md +++ b/unison-src/transcripts/fix1578.md @@ -76,9 +76,9 @@ baz bar = (bar, 42) -- here, `bar` refers to the parameter This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. ```unison:hide -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun -type Day = Day Int +structural type Day = Day Int use Zoot Zonk @@ -96,7 +96,7 @@ day1 = Day +1 Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. ```unison:hide -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun use Zoot Zonk diff --git a/unison-src/transcripts/fix1578.output.md b/unison-src/transcripts/fix1578.output.md index a0ae3d07ed..9ced24641d 100644 --- a/unison-src/transcripts/fix1578.output.md +++ b/unison-src/transcripts/fix1578.output.md @@ -68,9 +68,9 @@ baz bar = (bar, 42) -- here, `bar` refers to the parameter This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. ```unison -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun -type Day = Day Int +structural type Day = Day Int use Zoot Zonk @@ -88,7 +88,7 @@ day1 = Day +1 Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. ```unison -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun use Zoot Zonk diff --git a/unison-src/transcripts/fix1696.output.md b/unison-src/transcripts/fix1696.output.md index d930247073..c10b4aa859 100644 --- a/unison-src/transcripts/fix1696.output.md +++ b/unison-src/transcripts/fix1696.output.md @@ -19,9 +19,13 @@ dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") ```ucm - The expression in red needs the {Zoot} ability, but this location does not have access to any abilities. + I expected to see `structural` or `unique` at the start of + this line: - 13 | dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") + 1 | ability Ask where ask : Nat + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types ``` diff --git a/unison-src/transcripts/fix1731.md b/unison-src/transcripts/fix1731.md index 29fd0d5f0f..81adcd8de2 100644 --- a/unison-src/transcripts/fix1731.md +++ b/unison-src/transcripts/fix1731.md @@ -4,7 +4,7 @@ ``` ```unison:hide -ability CLI where +structural ability CLI where print : Text ->{CLI} () input : {CLI} Text ``` diff --git a/unison-src/transcripts/fix1731.output.md b/unison-src/transcripts/fix1731.output.md index 48fe35db69..3ed9b26b3a 100644 --- a/unison-src/transcripts/fix1731.output.md +++ b/unison-src/transcripts/fix1731.output.md @@ -1,6 +1,6 @@ ```unison -ability CLI where +structural ability CLI where print : Text ->{CLI} () input : {CLI} Text ``` diff --git a/unison-src/transcripts/fix1844.md b/unison-src/transcripts/fix1844.md index 9ebd3c27a5..41c189867c 100644 --- a/unison-src/transcripts/fix1844.md +++ b/unison-src/transcripts/fix1844.md @@ -1,6 +1,6 @@ ```unison -type One a = One a +structural type One a = One a unique type Woot a b c = Woot a b c unique type Z = Z diff --git a/unison-src/transcripts/fix1844.output.md b/unison-src/transcripts/fix1844.output.md index 172de373bb..7c9c1f5f3a 100644 --- a/unison-src/transcripts/fix1844.output.md +++ b/unison-src/transcripts/fix1844.output.md @@ -1,6 +1,6 @@ ```unison -type One a = One a +structural type One a = One a unique type Woot a b c = Woot a b c unique type Z = Z @@ -18,7 +18,7 @@ snoc k aN = match k with ⍟ These new definitions are ok to `add`: - type One a + structural type One a unique type Woot a b c unique type Z snoc : One a -> aN -> Woot (One a) (One aN) ##Nat diff --git a/unison-src/transcripts/fix2026.md b/unison-src/transcripts/fix2026.md index 56ddc81674..819a579e2f 100644 --- a/unison-src/transcripts/fix2026.md +++ b/unison-src/transcripts/fix2026.md @@ -3,7 +3,7 @@ ``` ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x ex = unsafeRun! '(printLine "hello world") diff --git a/unison-src/transcripts/fix2026.output.md b/unison-src/transcripts/fix2026.output.md index e28df2509d..b8b91f0955 100644 --- a/unison-src/transcripts/fix2026.output.md +++ b/unison-src/transcripts/fix2026.output.md @@ -1,5 +1,5 @@ ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x ex = unsafeRun! '(printLine "hello world") @@ -43,7 +43,7 @@ Exception.unsafeRun! e _ = ⍟ These new definitions are ok to `add`: - ability Exception + structural ability Exception (also named builtin.Exception) Exception.unsafeRun! : '{g, Exception} a -> '{g} a compose2 : (c ->{𝕖1} d) diff --git a/unison-src/transcripts/fix2091.md b/unison-src/transcripts/fix2091.md index aa26776289..1686b9b263 100644 --- a/unison-src/transcripts/fix2091.md +++ b/unison-src/transcripts/fix2091.md @@ -12,7 +12,7 @@ ability'' = 90 -- this type is the same as `type Either a b = Left a | Right b` -- but with very confusing names -- seriously don't ever do this -type type! type_ ability_ = ability' type_ | type! type_ +structural type type! type_ ability_ = ability' type_ | type! type_ unique type type!!! type_ ability_ = ability' type_ | type! type_ ``` diff --git a/unison-src/transcripts/fix2091.output.md b/unison-src/transcripts/fix2091.output.md index 894e2e8734..2e234fbeff 100644 --- a/unison-src/transcripts/fix2091.output.md +++ b/unison-src/transcripts/fix2091.output.md @@ -12,7 +12,7 @@ ability'' = 90 -- this type is the same as `type Either a b = Left a | Right b` -- but with very confusing names -- seriously don't ever do this -type type! type_ ability_ = ability' type_ | type! type_ +structural type type! type_ ability_ = ability' type_ | type! type_ unique type type!!! type_ ability_ = ability' type_ | type! type_ ``` @@ -25,7 +25,7 @@ unique type type!!! type_ ability_ = ability' type_ | type! type_ ⍟ These new definitions are ok to `add`: - type type! type_ ability_ + structural type type! type_ ability_ unique type type!!! type_ ability_ ability! : ##Nat ability'' : ##Nat diff --git a/unison-src/transcripts/fix2167.md b/unison-src/transcripts/fix2167.md index cb5a64f302..4e65ddb6f6 100644 --- a/unison-src/transcripts/fix2167.md +++ b/unison-src/transcripts/fix2167.md @@ -6,7 +6,7 @@ This is just a simple transcript to regression check an ability inference/checking issue. ```unison -ability R t where +structural ability R t where die : () -> x near.impl : Nat -> Either () [Nat] diff --git a/unison-src/transcripts/fix2167.output.md b/unison-src/transcripts/fix2167.output.md index 4a6f3de654..28826bdcf5 100644 --- a/unison-src/transcripts/fix2167.output.md +++ b/unison-src/transcripts/fix2167.output.md @@ -2,7 +2,7 @@ This is just a simple transcript to regression check an ability inference/checking issue. ```unison -ability R t where +structural ability R t where die : () -> x near.impl : Nat -> Either () [Nat] @@ -23,7 +23,7 @@ R.near1 region loc = match R.near 42 with ⍟ These new definitions are ok to `add`: - ability R t + structural ability R t R.near : Nat ->{R t} [Nat] R.near1 : region -> loc ->{R t} Nat diff --git a/unison-src/transcripts/fix2238.md b/unison-src/transcripts/fix2238.md index eaacb39b43..3562096397 100644 --- a/unison-src/transcripts/fix2238.md +++ b/unison-src/transcripts/fix2238.md @@ -6,7 +6,7 @@ This should not typecheck - the inline `@eval` expression uses abilities. ```unison:error -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ @eval{abort} }} ``` diff --git a/unison-src/transcripts/fix2238.output.md b/unison-src/transcripts/fix2238.output.md index 595118463b..a54cdd81b7 100644 --- a/unison-src/transcripts/fix2238.output.md +++ b/unison-src/transcripts/fix2238.output.md @@ -2,7 +2,7 @@ This should not typecheck - the inline `@eval` expression uses abilities. ```unison -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ @eval{abort} }} ``` diff --git a/unison-src/transcripts/fix2238.u b/unison-src/transcripts/fix2238.u index 01fcf7cc38..19e81357ee 100644 --- a/unison-src/transcripts/fix2238.u +++ b/unison-src/transcripts/fix2238.u @@ -1,5 +1,5 @@ -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ diff --git a/unison-src/transcripts/fix2254.md b/unison-src/transcripts/fix2254.md index 7e2559f375..95553d65b1 100644 --- a/unison-src/transcripts/fix2254.md +++ b/unison-src/transcripts/fix2254.md @@ -12,7 +12,7 @@ unique type A a b c d | C c | D d -type NeedsA a b = NeedsA (A a b Nat Nat) +structural type NeedsA a b = NeedsA (A a b Nat Nat) | Zoink Text f : A Nat Nat Nat Nat -> Nat @@ -66,7 +66,7 @@ Let's do the update now, and verify that the definitions all look good and there Here's a test of updating a record: ```unison -type Rec = { uno : Nat, dos : Nat } +structural type Rec = { uno : Nat, dos : Nat } combine r = uno r + dos r ``` @@ -76,7 +76,7 @@ combine r = uno r + dos r ``` ```unison -type Rec = { uno : Nat, dos : Nat, tres : Text } +structural type Rec = { uno : Nat, dos : Nat, tres : Text } ``` And checking that after updating this record, there's nothing `todo`: diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md index 3f53636f61..21b13d2d98 100644 --- a/unison-src/transcripts/fix2254.output.md +++ b/unison-src/transcripts/fix2254.output.md @@ -8,7 +8,7 @@ unique type A a b c d | C c | D d -type NeedsA a b = NeedsA (A a b Nat Nat) +structural type NeedsA a b = NeedsA (A a b Nat Nat) | Zoink Text f : A Nat Nat Nat Nat -> Nat @@ -41,7 +41,7 @@ We'll make our edits in a fork of the `a` namespace: ⍟ I've added these definitions: unique type A a b c d - type NeedsA a b + structural type NeedsA a b f : A Nat Nat Nat Nat -> Nat f2 : A Nat Nat Nat Nat -> Nat f3 : NeedsA Nat Nat -> Nat @@ -74,9 +74,16 @@ Let's do the update now, and verify that the definitions all look good and there .a2> view A NeedsA f f2 f3 g - unique type A a b c d = E a d | C c | A a | B b | D d + unique type A a b c d + = E a d + | C c + | A a + | B b + | D d - type NeedsA a b = Zoink Text | NeedsA (A a b Nat Nat) + structural type NeedsA a b + = Zoink Text + | NeedsA (A a b Nat Nat) f : A Nat Nat Nat Nat -> Nat f = cases @@ -113,7 +120,7 @@ Let's do the update now, and verify that the definitions all look good and there Here's a test of updating a record: ```unison -type Rec = { uno : Nat, dos : Nat } +structural type Rec = { uno : Nat, dos : Nat } combine r = uno r + dos r ``` @@ -126,7 +133,7 @@ combine r = uno r + dos r ⍟ These new definitions are ok to `add`: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -143,7 +150,7 @@ combine r = uno r + dos r ⍟ I've added these definitions: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -154,7 +161,7 @@ combine r = uno r + dos r ``` ```unison -type Rec = { uno : Nat, dos : Nat, tres : Text } +structural type Rec = { uno : Nat, dos : Nat, tres : Text } ``` ```ucm @@ -172,7 +179,7 @@ type Rec = { uno : Nat, dos : Nat, tres : Text } ⍟ These names already exist. You can `update` them to your new definition: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -198,7 +205,7 @@ And checking that after updating this record, there's nothing `todo`: ⍟ I've updated these names to your new definition: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec diff --git a/unison-src/transcripts/fix2344.md b/unison-src/transcripts/fix2344.md new file mode 100644 index 0000000000..6dd1e0ca21 --- /dev/null +++ b/unison-src/transcripts/fix2344.md @@ -0,0 +1,22 @@ + +Checks a corner case with type checking involving destructuring binds. + +The binds were causing some sequences of lets to be unnecessarily +recursive. + +```ucm:hide +.> builtins.merge +``` + +```unison +unique ability Nate where + nate: (Boolean, Nat) + antiNate: () + + +sneezy: (Nat -> {d} a) -> '{Nate,d} a +sneezy dee _ = + (_,_) = nate + antiNate + dee 1 +``` diff --git a/unison-src/transcripts/fix2344.output.md b/unison-src/transcripts/fix2344.output.md new file mode 100644 index 0000000000..b58713fbcb --- /dev/null +++ b/unison-src/transcripts/fix2344.output.md @@ -0,0 +1,31 @@ + +Checks a corner case with type checking involving destructuring binds. + +The binds were causing some sequences of lets to be unnecessarily +recursive. + +```unison +unique ability Nate where + nate: (Boolean, Nat) + antiNate: () + + +sneezy: (Nat -> {d} a) -> '{Nate,d} a +sneezy dee _ = + (_,_) = nate + antiNate + dee 1 +``` + +```ucm + + 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`: + + unique ability Nate + sneezy : (Nat ->{d} a) -> '{d, Nate} a + +``` diff --git a/unison-src/transcripts/fix2353.md b/unison-src/transcripts/fix2353.md new file mode 100644 index 0000000000..8c6c05c2de --- /dev/null +++ b/unison-src/transcripts/fix2353.md @@ -0,0 +1,16 @@ +```ucm:hide +.> builtins.merge +``` + +```unison +use builtin Scope +unique ability Async t g where async : Nat +unique ability Exception where raise : Nat -> x + +pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a +pure.run a0 a = + a' : forall s . '{Scope s, Exception, g} a + a' = 'a0 -- typechecks + -- make sure this builtin can still be referenced + Scope.run a' +``` diff --git a/unison-src/transcripts/fix2353.output.md b/unison-src/transcripts/fix2353.output.md new file mode 100644 index 0000000000..aa8bae78a4 --- /dev/null +++ b/unison-src/transcripts/fix2353.output.md @@ -0,0 +1,26 @@ +```unison +use builtin Scope +unique ability Async t g where async : Nat +unique ability Exception where raise : Nat -> x + +pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a +pure.run a0 a = + a' : forall s . '{Scope s, Exception, g} a + a' = 'a0 -- typechecks + -- make sure this builtin can still be referenced + Scope.run a' +``` + +```ucm + + 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`: + + unique ability Async t g + unique ability Exception + pure.run : a -> (βˆ€ t. '{Async t g} a) ->{g, Exception} a + +``` diff --git a/unison-src/transcripts/fix2355.md b/unison-src/transcripts/fix2355.md new file mode 100644 index 0000000000..25f4840b31 --- /dev/null +++ b/unison-src/transcripts/fix2355.md @@ -0,0 +1,25 @@ + +Tests for a loop that was previously occurring in the type checker. + +```ucm:hide +.> builtins.merge +``` + +```unison:error +structural ability A t g where + fork : '{g, A t g} a -> t a + await : t a -> a + empty! : t a + put : a -> t a -> () + +example : '{A t {}} Nat +example = 'let + r = A.empty! + go u = + t = A.fork '(go (u + 1)) + A.await t + + go 0 + t2 = A.fork '(A.put 10 r) + A.await r +``` diff --git a/unison-src/transcripts/fix2355.output.md b/unison-src/transcripts/fix2355.output.md new file mode 100644 index 0000000000..61e8b147f4 --- /dev/null +++ b/unison-src/transcripts/fix2355.output.md @@ -0,0 +1,40 @@ + +Tests for a loop that was previously occurring in the type checker. + +```unison +structural ability A t g where + fork : '{g, A t g} a -> t a + await : t a -> a + empty! : t a + put : a -> t a -> () + +example : '{A t {}} Nat +example = 'let + r = A.empty! + go u = + t = A.fork '(go (u + 1)) + A.await t + + go 0 + t2 = A.fork '(A.put 10 r) + A.await r +``` + +```ucm + + I tried to infer a cyclic ability. + + The expression in red was inferred to require the ability: + + {A t25 {𝕖39, 𝕖18}} + + where `𝕖18` is its overall abilities. + + I need a type signature to help figure this out. + + 10 | go u = + 11 | t = A.fork '(go (u + 1)) + 12 | A.await t + + +``` diff --git a/unison-src/transcripts/fix2378.md b/unison-src/transcripts/fix2378.md new file mode 100644 index 0000000000..d4358c26e9 --- /dev/null +++ b/unison-src/transcripts/fix2378.md @@ -0,0 +1,44 @@ + +Tests for an ability failure that was caused by order dependence of +checking wanted vs. provided abilities. It was necessary to re-check +rows until a fixed point is reached. + +```ucm:hide +.> builtins.merge +``` + +```unison +unique ability C c where + new : c a + receive : c a -> a + send : a -> c a -> () + +unique ability A t g where + fork : '{A t g, g, Exception} a -> t a + await : t a -> a + +unique ability Ex where raise : () -> x + +Ex.catch : '{Ex, g} a ->{g} Either () a +Ex.catch _ = todo "Exception.catch" + +C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r +C.pure.run _ = todo "C.pure.run" + +A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a +A.pure.run _ = todo "A.pure.run" + +ex : '{C c, A t {C c}} Nat +ex _ = + c = C.new + x = A.fork 'let + a = receive c + a + 10 + y = A.fork 'let + send 0 c + () + A.await x + +x : '{} (Either () Nat) +x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) +``` diff --git a/unison-src/transcripts/fix2378.output.md b/unison-src/transcripts/fix2378.output.md new file mode 100644 index 0000000000..e7d94119fd --- /dev/null +++ b/unison-src/transcripts/fix2378.output.md @@ -0,0 +1,59 @@ + +Tests for an ability failure that was caused by order dependence of +checking wanted vs. provided abilities. It was necessary to re-check +rows until a fixed point is reached. + +```unison +unique ability C c where + new : c a + receive : c a -> a + send : a -> c a -> () + +unique ability A t g where + fork : '{A t g, g, Exception} a -> t a + await : t a -> a + +unique ability Ex where raise : () -> x + +Ex.catch : '{Ex, g} a ->{g} Either () a +Ex.catch _ = todo "Exception.catch" + +C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r +C.pure.run _ = todo "C.pure.run" + +A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a +A.pure.run _ = todo "A.pure.run" + +ex : '{C c, A t {C c}} Nat +ex _ = + c = C.new + x = A.fork 'let + a = receive c + a + 10 + y = A.fork 'let + send 0 c + () + A.await x + +x : '{} (Either () Nat) +x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) +``` + +```ucm + + 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`: + + unique ability A t g + unique ability C c + unique ability Ex + A.pure.run : (βˆ€ t. '{g, A t g} a) ->{g, Ex} a + C.pure.run : (βˆ€ c. '{g, C c} r) ->{g, Ex} r + Ex.catch : '{g, Ex} a ->{g} Either () a + ex : '{C c, A t {C c}} Nat + x : 'Either () Nat + +``` diff --git a/unison-src/transcripts/fix689.md b/unison-src/transcripts/fix689.md index a156daa6aa..b22106eed4 100644 --- a/unison-src/transcripts/fix689.md +++ b/unison-src/transcripts/fix689.md @@ -5,7 +5,7 @@ Tests the fix for https://github.com/unisonweb/unison/issues/689 ``` ``` unison -ability SystemTime where +structural ability SystemTime where systemTime : ##Nat tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) diff --git a/unison-src/transcripts/fix689.output.md b/unison-src/transcripts/fix689.output.md index e4d39e5bcc..6f8b8db761 100644 --- a/unison-src/transcripts/fix689.output.md +++ b/unison-src/transcripts/fix689.output.md @@ -1,7 +1,7 @@ Tests the fix for https://github.com/unisonweb/unison/issues/689 ```unison -ability SystemTime where +structural ability SystemTime where systemTime : ##Nat tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) @@ -15,7 +15,7 @@ tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) ⍟ These new definitions are ok to `add`: - ability SystemTime + structural ability SystemTime tomorrow : '{SystemTime} Nat ``` diff --git a/unison-src/transcripts/fix693.md b/unison-src/transcripts/fix693.md index 49661aff3f..bcb714af97 100644 --- a/unison-src/transcripts/fix693.md +++ b/unison-src/transcripts/fix693.md @@ -4,10 +4,10 @@ ``` ```unison -ability X t where +structural ability X t where x : t -> a -> a -ability Abort where +structural ability Abort where abort : a ``` diff --git a/unison-src/transcripts/fix693.output.md b/unison-src/transcripts/fix693.output.md index 327115d8fc..32fef56cd8 100644 --- a/unison-src/transcripts/fix693.output.md +++ b/unison-src/transcripts/fix693.output.md @@ -1,9 +1,9 @@ ```unison -ability X t where +structural ability X t where x : t -> a -> a -ability Abort where +structural ability Abort where abort : a ``` @@ -15,8 +15,8 @@ ability Abort where ⍟ These new definitions are ok to `add`: - ability Abort - ability X t + structural ability Abort + structural ability X t ``` ```ucm @@ -24,8 +24,8 @@ ability Abort where ⍟ I've added these definitions: - ability Abort - ability X t + structural ability Abort + structural ability X t ``` This code should not type check. The match on X.x ought to introduce a diff --git a/unison-src/transcripts/fix987.md b/unison-src/transcripts/fix987.md index 28e39518de..0db69b1d78 100644 --- a/unison-src/transcripts/fix987.md +++ b/unison-src/transcripts/fix987.md @@ -6,7 +6,7 @@ First we'll add a definition: ```unison -ability DeathStar where +structural ability DeathStar where attack : Text -> () spaceAttack1 x = diff --git a/unison-src/transcripts/fix987.output.md b/unison-src/transcripts/fix987.output.md index ecf3169535..f63416f521 100644 --- a/unison-src/transcripts/fix987.output.md +++ b/unison-src/transcripts/fix987.output.md @@ -2,7 +2,7 @@ First we'll add a definition: ```unison -ability DeathStar where +structural ability DeathStar where attack : Text -> () spaceAttack1 x = @@ -19,7 +19,7 @@ spaceAttack1 x = ⍟ These new definitions are ok to `add`: - ability DeathStar + structural ability DeathStar spaceAttack1 : x ->{DeathStar} Text ``` @@ -30,7 +30,7 @@ Add it to the codebase: ⍟ I've added these definitions: - ability DeathStar + structural ability DeathStar spaceAttack1 : x ->{DeathStar} Text ``` diff --git a/unison-src/transcripts/higher-rank.md b/unison-src/transcripts/higher-rank.md new file mode 100644 index 0000000000..ee303a8a45 --- /dev/null +++ b/unison-src/transcripts/higher-rank.md @@ -0,0 +1,69 @@ + +This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. + +```ucm:hide +.> alias.type ##Nat Nat +.> alias.type ##Text Text +.> alias.type ##IO IO +``` + +In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: + +```unison +f : (forall a . a -> a) -> (Nat, Text) +f id = (id 1, id "hi") + +> f (x -> x) +``` + +Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: + +```unison +f : (forall a g . '{g} a -> '{g} a) -> () -> () +f id _ = + (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) + () +``` + +Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: + +```unison +unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) + +Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) +Functor.map = cases Functor f -> f + +Functor.blah : Functor f -> () +Functor.blah = cases Functor f -> + g : forall a b . (a -> b) -> f a -> f b + g = f + () +``` + +This example is similar, but involves abilities: + +```unison +unique ability Remote t where doRemoteStuff : () +unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) + +Loc.blah : Loc -> () +Loc.blah = cases Loc f -> + f0 : '{Remote tx} ax ->{Remote tx} tx ax + f0 = f + () + +-- In this case, no annotation is needed since the lambda +-- is checked against a polymorphic type +Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) + +-- In this case, the annotation is needed since f' is inferred +-- on its own it won't infer the higher-rank type +Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform2 nt = cases Loc f -> + f' : forall t a . '{Remote t} a ->{Remote t} t a + f' a = f (nt a) + Loc f' +``` \ No newline at end of file diff --git a/unison-src/transcripts/higher-rank.output.md b/unison-src/transcripts/higher-rank.output.md new file mode 100644 index 0000000000..5570cddbed --- /dev/null +++ b/unison-src/transcripts/higher-rank.output.md @@ -0,0 +1,126 @@ + +This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. + +In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: + +```unison +f : (forall a . a -> a) -> (Nat, Text) +f id = (id 1, id "hi") + +> f (x -> x) +``` + +```ucm + + 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`: + + f : (βˆ€ a. a ->{g} a) ->{g} (Nat, Text) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | > f (x -> x) + ⧩ + (1, "hi") + +``` +Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: + +```unison +f : (forall a g . '{g} a -> '{g} a) -> () -> () +f id _ = + (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) + () +``` + +```ucm + + 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`: + + f : (βˆ€ a g. '{g} a ->{h} '{g} a) -> '{h} () + +``` +Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: + +```unison +unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) + +Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) +Functor.map = cases Functor f -> f + +Functor.blah : Functor f -> () +Functor.blah = cases Functor f -> + g : forall a b . (a -> b) -> f a -> f b + g = f + () +``` + +```ucm + + 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`: + + unique type Functor f + Functor.blah : Functor f -> () + Functor.map : Functor f + -> (βˆ€ a b. (a -> b) -> f a -> f b) + +``` +This example is similar, but involves abilities: + +```unison +unique ability Remote t where doRemoteStuff : () +unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) + +Loc.blah : Loc -> () +Loc.blah = cases Loc f -> + f0 : '{Remote tx} ax ->{Remote tx} tx ax + f0 = f + () + +-- In this case, no annotation is needed since the lambda +-- is checked against a polymorphic type +Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) + +-- In this case, the annotation is needed since f' is inferred +-- on its own it won't infer the higher-rank type +Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform2 nt = cases Loc f -> + f' : forall t a . '{Remote t} a ->{Remote t} t a + f' a = f (nt a) + Loc f' +``` + +```ucm + + 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`: + + unique type Loc + unique ability Remote t + Loc.blah : Loc -> () + Loc.transform : (βˆ€ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc + Loc.transform2 : (βˆ€ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc + +``` diff --git a/unison-src/transcripts/lambdacase.md b/unison-src/transcripts/lambdacase.md index df546e7289..dcbc2559dc 100644 --- a/unison-src/transcripts/lambdacase.md +++ b/unison-src/transcripts/lambdacase.md @@ -73,7 +73,7 @@ it again shows the definition using the multi-argument `cases` syntax opportunis Here's another example: ```unison -type B = T | F +structural type B = T | F blah = cases T, x -> "hi" diff --git a/unison-src/transcripts/lambdacase.output.md b/unison-src/transcripts/lambdacase.output.md index 79727baed4..9b481c2339 100644 --- a/unison-src/transcripts/lambdacase.output.md +++ b/unison-src/transcripts/lambdacase.output.md @@ -117,7 +117,7 @@ it again shows the definition using the multi-argument `cases` syntax opportunis Here's another example: ```unison -type B = T | F +structural type B = T | F blah = cases T, x -> "hi" @@ -140,7 +140,7 @@ blorf = cases ⍟ These new definitions are ok to `add`: - type B + structural type B blah : B -> B -> Text blorf : B -> B -> B diff --git a/unison-src/transcripts/link.md b/unison-src/transcripts/link.md index 46720e385e..d3fde27594 100644 --- a/unison-src/transcripts/link.md +++ b/unison-src/transcripts/link.md @@ -48,6 +48,7 @@ We can look at the links we have: ```ucm .> links coolFunction +.> links coolFunction License ``` We can link the same metadata simultaneously to multiple definitions: @@ -67,4 +68,6 @@ myLibrary.h x = x + 3 .myLibrary> links g .myLibrary> links h .myLibrary> history + +.> unlink coolFunction.doc coolFunction ``` diff --git a/unison-src/transcripts/link.output.md b/unison-src/transcripts/link.output.md index d8401c644b..e507b82102 100644 --- a/unison-src/transcripts/link.output.md +++ b/unison-src/transcripts/link.output.md @@ -108,6 +108,13 @@ We can look at the links we have: Tip: Try using `display 1` to display the first result or `view 1` to view its source. +.> links coolFunction License + + 1. coolFunction.license : License + + Tip: Try using `display 1` to display the first result or + `view 1` to view its source. + ``` We can link the same metadata simultaneously to multiple definitions: @@ -193,4 +200,11 @@ myLibrary.h x = x + 3 β–‘ #7rksc58cce (start of history) +.> unlink coolFunction.doc coolFunction + + Updates: + + 1. coolFunction : Nat -> Nat + - 2. doc : Doc + ``` diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 936e112548..2492c0f190 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - βŠ™ #9bfm3siukb + βŠ™ #ndukqgvtrb - Deletes: feature1.y - βŠ™ #1mbl4b4t5g + βŠ™ #08c5fdtq6k + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - βŠ™ #fh9g1m1add + βŠ™ #o17okbu7ug + Adds / updates: feature1.y - βŠ™ #ahlnio3eom + βŠ™ #l37haj73av > Moves: Original name New name x master.x - βŠ™ #o2lqjr91e1 + βŠ™ #1h0i8koq55 + Adds / updates: x - β–‘ #9ied0t98hk (start of history) + β–‘ #2t9dm55015 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/names.md b/unison-src/transcripts/names.md index 88f405dbf7..dfda4a0c03 100644 --- a/unison-src/transcripts/names.md +++ b/unison-src/transcripts/names.md @@ -4,7 +4,7 @@ ``` ```unison:hide -type IntTriple = IntTriple (Int, Int, Int) +structural type IntTriple = IntTriple (Int, Int, Int) intTriple = IntTriple(+1, +1, +1) ``` diff --git a/unison-src/transcripts/names.output.md b/unison-src/transcripts/names.output.md index 9f9cb40a2f..4e4caa9ae6 100644 --- a/unison-src/transcripts/names.output.md +++ b/unison-src/transcripts/names.output.md @@ -1,6 +1,6 @@ Example uses of the `names` command and output ```unison -type IntTriple = IntTriple (Int, Int, Int) +structural type IntTriple = IntTriple (Int, Int, Int) intTriple = IntTriple(+1, +1, +1) ``` diff --git a/unison-src/transcripts/pattern-pretty-print-2345.md b/unison-src/transcripts/pattern-pretty-print-2345.md new file mode 100644 index 0000000000..83cb13d7af --- /dev/null +++ b/unison-src/transcripts/pattern-pretty-print-2345.md @@ -0,0 +1,73 @@ +Regression test for https://github.com/unisonweb/unison/pull/2377 + + +```ucm:hide +.> builtins.merge +``` + +```unison +structural ability Ab where + a: Nat -> () + +dopey = cases + ?0 -> () + +grumpy = cases + d -> () + +happy = cases + true -> () + +sneezy = cases + +1 -> () + +bashful = cases + Some a -> () + +mouthy = cases + [] -> () + +pokey = cases + h +: t -> () + +sleepy = cases + i :+ l -> () + +demure = cases + [0] -> () + +angry = cases + a ++ [] -> () + +tremulous = cases + (0,1) -> () + +throaty = cases + { Ab.a a -> k } -> () + +agitated = cases + a | a == 2 -> () + +doc = cases + y@4 -> () +``` + +```ucm +.> add +.> view dopey +.> view grumpy +.> view happy +.> view sneezy +.> view bashful +.> view mouthy +.> view pokey +.> view sleepy +.> view demure +.> view angry +.> view tremulous +.> view throaty +.> view agitated +.> view doc + +``` + diff --git a/unison-src/transcripts/pattern-pretty-print-2345.output.md b/unison-src/transcripts/pattern-pretty-print-2345.output.md new file mode 100644 index 0000000000..ae9732ea4d --- /dev/null +++ b/unison-src/transcripts/pattern-pretty-print-2345.output.md @@ -0,0 +1,167 @@ +Regression test for https://github.com/unisonweb/unison/pull/2377 + + +```unison +structural ability Ab where + a: Nat -> () + +dopey = cases + ?0 -> () + +grumpy = cases + d -> () + +happy = cases + true -> () + +sneezy = cases + +1 -> () + +bashful = cases + Some a -> () + +mouthy = cases + [] -> () + +pokey = cases + h +: t -> () + +sleepy = cases + i :+ l -> () + +demure = cases + [0] -> () + +angry = cases + a ++ [] -> () + +tremulous = cases + (0,1) -> () + +throaty = cases + { Ab.a a -> k } -> () + +agitated = cases + a | a == 2 -> () + +doc = cases + y@4 -> () +``` + +```ucm + + 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`: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : p4kl4dn7b41 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {Ab} x -> () + tremulous : (Nat, Nat) -> () + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : p4kl4dn7b41 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {Ab} x -> () + tremulous : (Nat, Nat) -> () + +.> view dopey + + dopey : Char -> () + dopey = cases ?0 -> () + +.> view grumpy + + grumpy : p4kl4dn7b41 -> () + grumpy = cases d -> () + +.> view happy + + happy : Boolean -> () + happy = cases true -> () + +.> view sneezy + + sneezy : Int -> () + sneezy = cases +1 -> () + +.> view bashful + + bashful : Optional a -> () + bashful = cases Some a -> () + +.> view mouthy + + mouthy : [t] -> () + mouthy = cases [] -> () + +.> view pokey + + pokey : [t] -> () + pokey = cases h +: t -> () + +.> view sleepy + + sleepy : [t] -> () + sleepy = cases i :+ l -> () + +.> view demure + + demure : [Nat] -> () + demure = cases [0] -> () + +.> view angry + + angry : [t] -> () + angry = cases a ++ [] -> () + +.> view tremulous + + tremulous : (Nat, Nat) -> () + tremulous = cases (0, 1) -> () + +.> view throaty + + throaty : Request {Ab} x -> () + throaty = cases {a a -> k} -> () + +.> view agitated + + agitated : Nat -> () + agitated = cases a | a == 2 -> () + +.> view doc + + doc : Nat -> () + doc = cases y@4 -> () + +``` diff --git a/unison-src/transcripts/records.md b/unison-src/transcripts/records.md new file mode 100644 index 0000000000..ab1bb4c998 --- /dev/null +++ b/unison-src/transcripts/records.md @@ -0,0 +1,70 @@ +Ensure that Records keep their syntax after being added to the codebase + +```ucm:hide +.> builtins.mergeio +.> load unison-src/transcripts-using-base/base.u +``` + +## Record with 1 field + +```unison:hide +unique type Record1 = { a : Text } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record1 +``` + +## Record with 2 fields + +```unison:hide +unique type Record2 = { a : Text, b : Int } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record2 +``` + +## Record with 3 fields + +```unison:hide +unique type Record3 = { a : Text, b : Int, c : Nat } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record3 +``` + +## Record with many fields + +```unison:hide +unique type Record4 = + { a : Text + , b : Int + , c : Nat + , d : Bytes + , e : Text + , f : Nat + , g : [Nat] + } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record4 +``` diff --git a/unison-src/transcripts/records.output.md b/unison-src/transcripts/records.output.md new file mode 100644 index 0000000000..cc9547a26a --- /dev/null +++ b/unison-src/transcripts/records.output.md @@ -0,0 +1,65 @@ +Ensure that Records keep their syntax after being added to the codebase + +## Record with 1 field + +```unison +unique type Record1 = { a : Text } +``` + +```ucm +.> view Record1 + + unique type Record1 = { a : Text } + +``` +## Record with 2 fields + +```unison +unique type Record2 = { a : Text, b : Int } +``` + +```ucm +.> view Record2 + + unique type Record2 = { a : Text, b : Int } + +``` +## Record with 3 fields + +```unison +unique type Record3 = { a : Text, b : Int, c : Nat } +``` + +```ucm +.> view Record3 + + unique type Record3 = { a : Text, b : Int, c : Nat } + +``` +## Record with many fields + +```unison +unique type Record4 = + { a : Text + , b : Int + , c : Nat + , d : Bytes + , e : Text + , f : Nat + , g : [Nat] + } +``` + +```ucm +.> view Record4 + + unique type Record4 + = { a : Text, + b : Int, + c : Nat, + d : Bytes, + e : Text, + f : Nat, + g : [Nat] } + +``` diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index cfb916f635..ffb2625466 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #h5ii1cefto .old` to make an old namespace + `fork #a0efcgu3if .old` to make an old namespace accessible again, - `reset-root #h5ii1cefto` to reset the root namespace and + `reset-root #a0efcgu3if` to reset the root namespace and its history to that of the specified namespace. - 1. #a34n023ojd : add - 2. #h5ii1cefto : add - 3. #9ied0t98hk : builtins.merge + 1. #bu1ni2nh4n : add + 2. #a0efcgu3if : add + 3. #2t9dm55015 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/scope-ref.md b/unison-src/transcripts/scope-ref.md new file mode 100644 index 0000000000..691ba7c5f7 --- /dev/null +++ b/unison-src/transcripts/scope-ref.md @@ -0,0 +1,19 @@ + +A short script to test mutable references with local scope. + +```ucm:hide +.> builtins.mergeio +``` + +```unison +test = Scope.run 'let + r = Scope.ref 0 + Ref.write r 1 + i = Ref.read r + Ref.write r 2 + j = Ref.read r + Ref.write r 5 + (i, j, Ref.read r) + +> test +``` diff --git a/unison-src/transcripts/scope-ref.output.md b/unison-src/transcripts/scope-ref.output.md new file mode 100644 index 0000000000..135b2d329c --- /dev/null +++ b/unison-src/transcripts/scope-ref.output.md @@ -0,0 +1,34 @@ + +A short script to test mutable references with local scope. + +```unison +test = Scope.run 'let + r = Scope.ref 0 + Ref.write r 1 + i = Ref.read r + Ref.write r 2 + j = Ref.read r + Ref.write r 5 + (i, j, Ref.read r) + +> test +``` + +```ucm + + 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`: + + test : (Nat, Nat, Nat) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 10 | > test + ⧩ + (1, 2, 5) + +``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 47d97fd6df..903bec803a 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - β–‘ #u5rtlqmmgp (start of history) + β–‘ #a1l0ads644 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - βŠ™ #3ia3q75nlj + βŠ™ #d4pjujecp5 > Moves: Original name New name Nat.frobnicate Nat.+ - βŠ™ #2gaqk05una + βŠ™ #36p4l2nurp > Moves: Original name New name Nat.+ Nat.frobnicate - β–‘ #u5rtlqmmgp (start of history) + β–‘ #a1l0ads644 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - βŠ™ #3ia3q75nlj + βŠ™ #d4pjujecp5 > Moves: Original name New name Nat.frobnicate Nat.+ - βŠ™ #2gaqk05una + βŠ™ #36p4l2nurp > Moves: Original name New name Nat.+ Nat.frobnicate - β–‘ #u5rtlqmmgp (start of history) + β–‘ #a1l0ads644 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - β–‘ #u5rtlqmmgp (start of history) + β–‘ #a1l0ads644 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - βŠ™ #a6t7mgqv2m + βŠ™ #q2j8o0ianj - Deletes: Nat.* Nat.+ - β–‘ #u5rtlqmmgp (start of history) + β–‘ #a1l0ads644 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. diff --git a/unison-src/transcripts/top-level-exceptions.output.md b/unison-src/transcripts/top-level-exceptions.output.md index 9c052d3f7f..5471c0c461 100644 --- a/unison-src/transcripts/top-level-exceptions.output.md +++ b/unison-src/transcripts/top-level-exceptions.output.md @@ -6,7 +6,7 @@ FYI, here are the `Exception` and `Failure` types: ```ucm .> view Exception Failure - ability builtin.Exception where + structural ability builtin.Exception where raise : Failure ->{builtin.Exception} x unique type builtin.io2.Failure diff --git a/unison-src/transcripts/type-modifier-required.md b/unison-src/transcripts/type-modifier-required.md new file mode 100644 index 0000000000..1b47bf78e7 --- /dev/null +++ b/unison-src/transcripts/type-modifier-required.md @@ -0,0 +1,26 @@ +# Type modifiers are required + +```ucm:hide +.> builtins.merge +``` + +Types needs to be prefixed with either `unique` or `structural`: + +```unison:error +type Abc = Abc +``` + +Abilities needs to be prefixed with either `unique` or `structural`: + +```unison:error +ability MyAbility where const : a +``` + +There should be no errors when `unique` or `structural` is provided: + +```unison +structural type AbcS = AbcS +unique type AbcU = AbcU +structural ability MyAbilityS where const : a +unique ability MyAbilityU where const : a +``` \ No newline at end of file diff --git a/unison-src/transcripts/type-modifier-required.output.md b/unison-src/transcripts/type-modifier-required.output.md new file mode 100644 index 0000000000..accdb1732f --- /dev/null +++ b/unison-src/transcripts/type-modifier-required.output.md @@ -0,0 +1,62 @@ +# Type modifiers are required + +Types needs to be prefixed with either `unique` or `structural`: + +```unison +type Abc = Abc +``` + +```ucm + + I expected to see `structural` or `unique` at the start of + this line: + + 1 | type Abc = Abc + + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types + +``` +Abilities needs to be prefixed with either `unique` or `structural`: + +```unison +ability MyAbility where const : a +``` + +```ucm + + I expected to see `structural` or `unique` at the start of + this line: + + 1 | ability MyAbility where const : a + + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types + +``` +There should be no errors when `unique` or `structural` is provided: + +```unison +structural type AbcS = AbcS +unique type AbcU = AbcU +structural ability MyAbilityS where const : a +unique ability MyAbilityU where const : a +``` + +```ucm + + 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`: + + structural type AbcS + (also named builtin.Unit) + unique type AbcU + structural ability MyAbilityS + unique ability MyAbilityU + +``` diff --git a/unison-src/transcripts/unsafe-coerce.md b/unison-src/transcripts/unsafe-coerce.md new file mode 100644 index 0000000000..0a5c5572b1 --- /dev/null +++ b/unison-src/transcripts/unsafe-coerce.md @@ -0,0 +1,23 @@ + +```ucm:hide +.> builtins.mergeio +``` + +```unison +f : '{} Nat +f _ = 5 + +fc : '{IO, Exception} Nat +fc = unsafe.coerceAbilities f + +main : '{IO, Exception} [Result] +main _ = + n = !fc + if n == 5 then [Ok ""] else [Fail ""] +``` + +```ucm +.> find unsafe.coerceAbilities +.> add +.> io.test main +``` diff --git a/unison-src/transcripts/unsafe-coerce.output.md b/unison-src/transcripts/unsafe-coerce.output.md new file mode 100644 index 0000000000..d037df9f9a --- /dev/null +++ b/unison-src/transcripts/unsafe-coerce.output.md @@ -0,0 +1,52 @@ + +```unison +f : '{} Nat +f _ = 5 + +fc : '{IO, Exception} Nat +fc = unsafe.coerceAbilities f + +main : '{IO, Exception} [Result] +main _ = + n = !fc + if n == 5 then [Ok ""] else [Fail ""] +``` + +```ucm + + 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`: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] + +``` +```ucm +.> find unsafe.coerceAbilities + + 1. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + + +.> add + + ⍟ I've added these definitions: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] + +.> io.test main + + New test results: + + β—‰ main + + βœ… 1 test(s) passing + + Tip: Use view main to view the source of a test. + +```