mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
⅄ trunk → update-defn-order
This commit is contained in:
commit
e64ffb6f2c
2
.github/workflows/ci.yaml
vendored
2
.github/workflows/ci.yaml
vendored
@ -388,7 +388,7 @@ jobs:
|
||||
write-mode: overwrite
|
||||
contents: |
|
||||
```ucm
|
||||
.> project.create-empty jit-setup
|
||||
scratch/main> project.create-empty jit-setup
|
||||
jit-setup/main> lib.install ${{ env.jit_version }}
|
||||
```
|
||||
```unison
|
||||
|
4
.ormolu
Normal file
4
.ormolu
Normal file
@ -0,0 +1,4 @@
|
||||
infixl 8 ^?
|
||||
infixr 4 %%~, %~
|
||||
infixl 3 <|>
|
||||
infixl 1 &, <&>
|
@ -10,7 +10,7 @@ import U.Codebase.HashTags
|
||||
import Unison.Hashing.V2 qualified as Hashing
|
||||
import Unison.Hashing.V2.Convert2 (convertBranchV3, v2ToH2Branch)
|
||||
|
||||
hashBranch :: forall m. Monad m => Branch m -> m BranchHash
|
||||
hashBranch :: forall m. (Monad m) => Branch m -> m BranchHash
|
||||
hashBranch branch =
|
||||
BranchHash . Hashing.contentHash <$> v2ToH2Branch branch
|
||||
|
||||
|
@ -100,7 +100,7 @@ v2ToH2Referent = \case
|
||||
V2Referent.Ref r -> H2.ReferentRef (v2ToH2Reference r)
|
||||
V2Referent.Con r cid -> H2.ReferentCon (v2ToH2Reference r) cid
|
||||
|
||||
v2ToH2Branch :: Monad m => V2.Branch m -> m H2.Branch
|
||||
v2ToH2Branch :: (Monad m) => V2.Branch m -> m H2.Branch
|
||||
v2ToH2Branch V2.Branch {terms, types, patches, children} = do
|
||||
hterms <-
|
||||
traverse sequenceA terms
|
||||
@ -166,7 +166,7 @@ hashPatchFormatToH2Patch Memory.PatchFull.Patch {termEdits, typeEdits} =
|
||||
V2Referent.Con typeRef conId -> do
|
||||
(H2.ReferentCon (v2ToH2Reference $ second unComponentHash typeRef) conId)
|
||||
|
||||
v2ToH2Term :: forall v. Ord v => V2.Term.HashableTerm v -> H2.Term v ()
|
||||
v2ToH2Term :: forall v. (Ord v) => V2.Term.HashableTerm v -> H2.Term v ()
|
||||
v2ToH2Term = ABT.transform convertF
|
||||
where
|
||||
convertF :: V2.Term.F' Text V2.Term.HashableTermRef V2.Term.TypeRef V2.Term.HashableTermLink V2.Term.TypeLink v a1 -> H2.TermF v () () a1
|
||||
|
@ -173,7 +173,7 @@ decodeWatchResultFormat =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- unsyncs
|
||||
|
||||
unsyncTermComponent :: HasCallStack => TermFormat.SyncLocallyIndexedComponent' t d -> Either DecodeError (TermFormat.LocallyIndexedComponent' t d)
|
||||
unsyncTermComponent :: (HasCallStack) => TermFormat.SyncLocallyIndexedComponent' t d -> Either DecodeError (TermFormat.LocallyIndexedComponent' t d)
|
||||
unsyncTermComponent (TermFormat.SyncLocallyIndexedComponent terms) = do
|
||||
let phi (localIds, bs) = do
|
||||
(a, b) <- decodeSyncTermAndType bs
|
||||
|
@ -39,7 +39,7 @@ data HashHandle = HashHandle
|
||||
toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference,
|
||||
-- | Hash decl's mentions
|
||||
toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference,
|
||||
hashBranch :: forall m. Monad m => Branch m -> m BranchHash,
|
||||
hashBranch :: forall m. (Monad m) => Branch m -> m BranchHash,
|
||||
hashBranchV3 :: forall m. BranchV3 m -> BranchHash,
|
||||
hashCausal ::
|
||||
-- The causal's namespace hash
|
||||
|
@ -109,23 +109,23 @@ localizePatchG (Patch termEdits typeEdits) =
|
||||
-- General-purpose localization
|
||||
|
||||
-- Contains references to branch objects.
|
||||
class Ord c => ContainsBranches c s where
|
||||
class (Ord c) => ContainsBranches c s where
|
||||
branches_ :: Lens' s (Map c LocalBranchChildId)
|
||||
|
||||
-- Contains references to definition objects i.e. term/decl component objects.
|
||||
class Ord d => ContainsDefns d s where
|
||||
class (Ord d) => ContainsDefns d s where
|
||||
defns_ :: Lens' s (Map d LocalDefnId)
|
||||
|
||||
-- Contains references to objects by their hash.
|
||||
class Ord h => ContainsHashes h s where
|
||||
class (Ord h) => ContainsHashes h s where
|
||||
hashes_ :: Lens' s (Map h LocalHashId)
|
||||
|
||||
-- Contains references to patch objects.
|
||||
class Ord p => ContainsPatches p s where
|
||||
class (Ord p) => ContainsPatches p s where
|
||||
patches_ :: Lens' s (Map p LocalPatchObjectId)
|
||||
|
||||
-- Contains text.
|
||||
class Ord t => ContainsText t s where
|
||||
class (Ord t) => ContainsText t s where
|
||||
texts_ :: Lens' s (Map t LocalTextId)
|
||||
|
||||
-- The inner state of the localization of a branch object.
|
||||
@ -137,16 +137,16 @@ data LocalizeBranchState t d p c = LocalizeBranchState
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Ord t => ContainsText t (LocalizeBranchState t d p c) where
|
||||
instance (Ord t) => ContainsText t (LocalizeBranchState t d p c) where
|
||||
texts_ = field @"texts"
|
||||
|
||||
instance Ord d => ContainsDefns d (LocalizeBranchState t d p c) where
|
||||
instance (Ord d) => ContainsDefns d (LocalizeBranchState t d p c) where
|
||||
defns_ = field @"defns"
|
||||
|
||||
instance Ord p => ContainsPatches p (LocalizeBranchState t d p c) where
|
||||
instance (Ord p) => ContainsPatches p (LocalizeBranchState t d p c) where
|
||||
patches_ = field @"patches"
|
||||
|
||||
instance Ord c => ContainsBranches c (LocalizeBranchState t d p c) where
|
||||
instance (Ord c) => ContainsBranches c (LocalizeBranchState t d p c) where
|
||||
branches_ = field @"branches"
|
||||
|
||||
-- | Run a computation that localizes a branch object, returning the local ids recorded within.
|
||||
@ -171,13 +171,13 @@ data LocalizePatchState t h d = LocalizePatchState
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Ord t => ContainsText t (LocalizePatchState t h d) where
|
||||
instance (Ord t) => ContainsText t (LocalizePatchState t h d) where
|
||||
texts_ = field @"texts"
|
||||
|
||||
instance Ord h => ContainsHashes h (LocalizePatchState t h d) where
|
||||
instance (Ord h) => ContainsHashes h (LocalizePatchState t h d) where
|
||||
hashes_ = field @"hashes"
|
||||
|
||||
instance Ord d => ContainsDefns d (LocalizePatchState t h d) where
|
||||
instance (Ord d) => ContainsDefns d (LocalizePatchState t h d) where
|
||||
defns_ = field @"defns"
|
||||
|
||||
-- Run a computation that localizes a patch object, returning the local ids recorded within.
|
||||
|
@ -58,7 +58,7 @@ instance (FromRow ref) => FromRow (NamedRef ref) where
|
||||
newtype ScopedRow ref
|
||||
= ScopedRow (NamedRef ref)
|
||||
|
||||
instance ToRow ref => ToRow (ScopedRow ref) where
|
||||
instance (ToRow ref) => ToRow (ScopedRow ref) where
|
||||
toRow (ScopedRow (NamedRef {reversedSegments = revSegments, ref})) =
|
||||
SQLText reversedName : SQLText namespace : SQLText lastNameSegment : toRow ref
|
||||
where
|
||||
|
@ -55,7 +55,7 @@ patchT_ f Patch {termEdits, typeEdits} = do
|
||||
newTypeEdits <- traverseOf (Map.bitraversed (Reference.t_) (Set.traverse . traverseFirst)) f typeEdits
|
||||
pure Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}
|
||||
where
|
||||
traverseFirst :: Bitraversable b => Traversal (b a c) (b a' c) a a'
|
||||
traverseFirst :: (Bitraversable b) => Traversal (b a c) (b a' c) a a'
|
||||
traverseFirst f = bitraverse f pure
|
||||
|
||||
patchH_ :: (Ord t, Ord h') => Traversal (Patch' t h o) (Patch' t h' o) h h'
|
||||
|
@ -289,7 +289,7 @@ module U.Codebase.Sqlite.Queries
|
||||
-- * Types
|
||||
NamespaceText,
|
||||
TextPathSegments,
|
||||
JsonParseFailure(..),
|
||||
JsonParseFailure (..),
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -462,7 +462,7 @@ putDeclFormat = \case
|
||||
putDeclComponent (DeclFormat.LocallyIndexedComponent v) =
|
||||
putFramedArray (putPair putLocalIds putDeclElement) v
|
||||
|
||||
putDeclElement :: MonadPut m => Decl.DeclR DeclFormat.TypeRef Symbol -> m ()
|
||||
putDeclElement :: (MonadPut m) => Decl.DeclR DeclFormat.TypeRef Symbol -> m ()
|
||||
putDeclElement Decl.DataDeclaration {..} = do
|
||||
putDeclType declType
|
||||
putModifier modifier
|
||||
@ -499,7 +499,7 @@ getDeclElement =
|
||||
1 -> pure Decl.Effect
|
||||
other -> unknownTag "DeclType" other
|
||||
|
||||
getModifier :: MonadGet m => m Modifier
|
||||
getModifier :: (MonadGet m) => m Modifier
|
||||
getModifier =
|
||||
getWord8 >>= \case
|
||||
0 -> pure Decl.Structural
|
||||
@ -720,7 +720,7 @@ getLocalBranch =
|
||||
x -> unknownTag "getMetadataSetFormat" x
|
||||
|
||||
getBranchDiff' ::
|
||||
MonadGet m =>
|
||||
(MonadGet m) =>
|
||||
m branchRef ->
|
||||
m (BranchFormat.BranchLocalIds' text defRef patchRef childRef) ->
|
||||
m (BranchFormat.BranchFormat' text defRef patchRef childRef branchRef)
|
||||
|
@ -19,11 +19,11 @@ data Causal m hc he pe e = Causal
|
||||
}
|
||||
deriving stock (Functor, Generic)
|
||||
|
||||
instance Eq hc => Eq (Causal m hc he pe e) where
|
||||
instance (Eq hc) => Eq (Causal m hc he pe e) where
|
||||
(==) = (==) `on` causalHash
|
||||
|
||||
-- | @emap f g@ maps over the values and parents' values with @f@ and @g@.
|
||||
emap :: Functor m => (e -> e') -> (pe -> pe') -> Causal m hc he pe e -> Causal m hc he pe' e'
|
||||
emap :: (Functor m) => (e -> e') -> (pe -> pe') -> Causal m hc he pe e -> Causal m hc he pe' e'
|
||||
emap f g causal@Causal {parents, value} =
|
||||
causal
|
||||
{ parents = Map.map (fmap (emap g g)) parents,
|
||||
|
@ -41,11 +41,11 @@ data DeclR r v = DataDeclaration
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
allVars :: Ord v => DeclR r v -> Set v
|
||||
allVars :: (Ord v) => DeclR r v -> Set v
|
||||
allVars (DataDeclaration _ _ bound constructorTypes) =
|
||||
(Set.fromList $ foldMap ABT.allVars constructorTypes) <> Set.fromList bound
|
||||
|
||||
vmap :: Ord v' => (v -> v') -> DeclR r v -> DeclR r v'
|
||||
vmap :: (Ord v') => (v -> v') -> DeclR r v -> DeclR r v'
|
||||
vmap f (DataDeclaration {declType, modifier, bound, constructorTypes}) =
|
||||
DataDeclaration
|
||||
{ declType,
|
||||
@ -82,7 +82,7 @@ data F a
|
||||
-- to the relevant piece of the component in the component map.
|
||||
unhashComponent ::
|
||||
forall v extra.
|
||||
ABT.Var v =>
|
||||
(ABT.Var v) =>
|
||||
Hash ->
|
||||
-- | A function to convert a reference to a variable. The actual var names aren't important.
|
||||
(Reference.Id -> v) ->
|
||||
|
@ -207,7 +207,7 @@ extraMapM ftext ftermRef ftypeRef ftermLink ftypeLink fvt = go'
|
||||
rmapPattern :: (t -> t') -> (r -> r') -> Pattern t r -> Pattern t' r'
|
||||
rmapPattern ft fr p = runIdentity . rmapPatternM (pure . ft) (pure . fr) $ p
|
||||
|
||||
rmapPatternM :: Applicative m => (t -> m t') -> (r -> m r') -> Pattern t r -> m (Pattern t' r')
|
||||
rmapPatternM :: (Applicative m) => (t -> m t') -> (r -> m r') -> Pattern t r -> m (Pattern t' r')
|
||||
rmapPatternM ft fr = go
|
||||
where
|
||||
go = \case
|
||||
@ -260,7 +260,7 @@ dependencies =
|
||||
-- to the relevant piece of the component in the component map.
|
||||
unhashComponent ::
|
||||
forall v extra.
|
||||
ABT.Var v =>
|
||||
(ABT.Var v) =>
|
||||
-- | The hash of the component, this is used to fill in self-references.
|
||||
Hash ->
|
||||
-- | A function to convert a reference to a variable. The actual var names aren't important.
|
||||
|
@ -27,12 +27,13 @@ newtype NameSegment = NameSegment
|
||||
deriving newtype (Alphabetical)
|
||||
|
||||
instance
|
||||
TypeError
|
||||
( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a"
|
||||
':$$: 'TypeError.Text "special-cased segment it should exist as a constant in"
|
||||
':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via"
|
||||
':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”."
|
||||
) =>
|
||||
( TypeError
|
||||
( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a"
|
||||
':$$: 'TypeError.Text "special-cased segment it should exist as a constant in"
|
||||
':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via"
|
||||
':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”."
|
||||
)
|
||||
) =>
|
||||
IsString NameSegment
|
||||
where
|
||||
fromString = undefined
|
||||
|
@ -18,10 +18,10 @@ import Data.Text (Text)
|
||||
class (Eq n) => Alphabetical n where
|
||||
compareAlphabetical :: n -> n -> Ordering
|
||||
|
||||
sortAlphabetically :: Alphabetical a => [a] -> [a]
|
||||
sortAlphabetically :: (Alphabetical a) => [a] -> [a]
|
||||
sortAlphabetically as = (\(OrderAlphabetically a) -> a) <$> List.sort (map OrderAlphabetically as)
|
||||
|
||||
sortAlphabeticallyOn :: Alphabetical a => (b -> a) -> [b] -> [b]
|
||||
sortAlphabeticallyOn :: (Alphabetical a) => (b -> a) -> [b] -> [b]
|
||||
sortAlphabeticallyOn f = List.sortOn (OrderAlphabetically . f)
|
||||
|
||||
instance Alphabetical Text where
|
||||
|
@ -154,7 +154,7 @@ getVector getA = do
|
||||
length <- getVarInt
|
||||
Vector.replicateM length getA
|
||||
|
||||
skipVector :: MonadGet m => m a -> m ()
|
||||
skipVector :: (MonadGet m) => m a -> m ()
|
||||
skipVector getA = do
|
||||
length <- getVarInt
|
||||
replicateM_ length getA
|
||||
|
@ -22,7 +22,7 @@ We use 0.5.0.1 of Ormolu and CI will add an extra commit, if needed, to autoform
|
||||
|
||||
Also note that you can always wrap a comment around some code you don't want Ormolu to touch, using:
|
||||
|
||||
```
|
||||
```haskell
|
||||
{- ORMOLU_DISABLE -}
|
||||
dontFormatMe = do blah
|
||||
blah
|
||||
@ -96,11 +96,13 @@ This codebase uses symlinks as a workaround for some inconveniences in the `here
|
||||
|
||||
First you'll need to enable "Developer Mode" in your Windows settings.
|
||||
|
||||
See https://consumer.huawei.com/en/support/content/en-us15594140/
|
||||
> See https://consumer.huawei.com/en/support/content/en-us15594140/
|
||||
|
||||
Then you'll need to enable symlink support in your `git` configuration, e.g.
|
||||
|
||||
`git config core.symlinks true`
|
||||
```shell
|
||||
git config core.symlinks true
|
||||
```
|
||||
|
||||
And then ask `git` to fix up your symlinks with `git checkout .`
|
||||
|
||||
@ -113,10 +115,41 @@ Stack doesn't work deterministically in Windows due to mismatched expectations a
|
||||
|
||||
## Building with Nix
|
||||
|
||||
__NB__: It is important that the Unison Nix cache is trusted when building, otherwise you will likely end up building hundreds of packages, including GHC itself.
|
||||
|
||||
The recommended way to do this is to add the public key and URL for the cache to your system’s Nix configuration. /etc/nix/nix.conf should have lines similar to
|
||||
```conf
|
||||
trusted-public-keys = unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k=
|
||||
trusted-substituters = https://unison.cachix.org
|
||||
```
|
||||
these lines could be prefixed with `extra-` and they may have additional entries besides the ones for our cache.
|
||||
|
||||
This command should work if you don’t want to edit the file manually:
|
||||
```shell
|
||||
sudo sh -c 'echo "extra-trusted-public-keys = unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k=
|
||||
extra-trusted-substituters = https://unison.cachix.org" >>/etc/nix/nix.conf'
|
||||
```
|
||||
After updating /etc/nix/nix.conf, you need to restart the Nix daemon. To do this on
|
||||
- Ubuntu: `sudo systemctl restart nix-daemon`
|
||||
- MacOS:
|
||||
```shell
|
||||
sudo launchctl unload /Library/LaunchDaemons/org.nixos.nix-daemon.plist
|
||||
sudo launchctl load /Library/LaunchDaemons/org.nixos.nix-daemon.plist
|
||||
```
|
||||
|
||||
If you use NixOS, you may instead add this via your configuration.nix with
|
||||
```nix
|
||||
nix.settings.trusted-public-keys = ["unison.cachix.org-1:i1DUFkisRPVOyLp/vblDsbsObmyCviq/zs6eRuzth3k="];
|
||||
nix.settings.trusted-substituters = ["https://unison.cachix.org"];
|
||||
```
|
||||
and run `sudo nixos-rebuild switch` afterward.
|
||||
|
||||
It is _not_ recommended to add your user to `trusted-users`. This _can_ make enabling flake configurations simpler (like the Unison Nix cache here), but [it is equivalent to giving that user root access (without need for sudo)](https://nix.dev/manual/nix/2.23/command-ref/conf-file.html#conf-trusted-users).
|
||||
|
||||
## Building package components with nix
|
||||
|
||||
### Build the unison executable
|
||||
```
|
||||
```shell
|
||||
nix build
|
||||
```
|
||||
|
||||
@ -125,7 +158,7 @@ This is specified with the normal
|
||||
`<package>:<component-type>:<component-name>` triple.
|
||||
|
||||
Some examples:
|
||||
```
|
||||
```shell
|
||||
nix build '.#component-unison-cli:lib:unison-cli'
|
||||
nix build '.#component-unison-syntax:test:syntax-tests'
|
||||
nix build '.#component-unison-cli:exe:transcripts'
|
||||
@ -143,7 +176,7 @@ include:
|
||||
- ormolu
|
||||
- haskell-language-server
|
||||
|
||||
```
|
||||
```shell
|
||||
nix develop
|
||||
```
|
||||
|
||||
@ -153,7 +186,7 @@ versions of the compiler and other development tools. Additionally,
|
||||
all non-local haskell dependencies (including profiling dependencies)
|
||||
are provided in the nix shell.
|
||||
|
||||
```
|
||||
```shell
|
||||
nix develop '.#cabal-local'
|
||||
```
|
||||
|
||||
@ -163,17 +196,17 @@ versions of the compiler and other development tools. Additionally,
|
||||
all haskell dependencies of this package are provided by the nix shell
|
||||
(including profiling dependencies).
|
||||
|
||||
```
|
||||
```shell
|
||||
nix develop '.#cabal-<package-name>'
|
||||
```
|
||||
|
||||
for example:
|
||||
|
||||
```
|
||||
```shell
|
||||
nix develop '.#cabal-unison-cli'
|
||||
```
|
||||
or
|
||||
```
|
||||
```shell
|
||||
nix develop '.#cabal-unison-parser-typechecker'
|
||||
```
|
||||
|
||||
@ -182,7 +215,7 @@ want to profile `unison-cli-main:exe:unison` then you could get into one of thes
|
||||
shells, cd into its directory, then run the program with
|
||||
profiling.
|
||||
|
||||
```
|
||||
```shell
|
||||
nix develop '.#cabal-unison-parser-typechecker'
|
||||
cd unison-cli
|
||||
cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p
|
||||
|
@ -102,7 +102,7 @@ import Witch as X (From (from), TryFrom (tryFrom), TryFromException (TryFromExce
|
||||
import Witherable as X (filterA, forMaybe, mapMaybe, wither, witherMap)
|
||||
|
||||
-- | Can be removed when we upgrade transformers to a more recent version.
|
||||
hoistMaybe :: Applicative m => Maybe a -> MaybeT m a
|
||||
hoistMaybe :: (Applicative m) => Maybe a -> MaybeT m a
|
||||
hoistMaybe = MaybeT . pure
|
||||
|
||||
-- | Like 'fold' but for Alternative.
|
||||
|
@ -41,7 +41,7 @@ import Data.Vector qualified as Vector
|
||||
import Unison.Prelude hiding (bimap, foldM, for_)
|
||||
|
||||
-- | A common case of @Map.merge@. Like @alignWith@, but includes the key.
|
||||
alignWithKey :: Ord k => (k -> These a b -> c) -> Map k a -> Map k b -> Map k c
|
||||
alignWithKey :: (Ord k) => (k -> These a b -> c) -> Map k a -> Map k b -> Map k c
|
||||
alignWithKey f =
|
||||
Map.merge
|
||||
(Map.mapMissing \k x -> f k (This x))
|
||||
@ -60,7 +60,7 @@ bitraversed keyT valT f m =
|
||||
|
||||
-- | Traverse a map as a list of key-value pairs.
|
||||
-- Note: This can have unexpected results if the result contains duplicate keys.
|
||||
asList_ :: Ord k' => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')]
|
||||
asList_ :: (Ord k') => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')]
|
||||
asList_ f s =
|
||||
s
|
||||
& Map.toList
|
||||
@ -73,13 +73,13 @@ swap =
|
||||
Map.foldlWithKey' (\z a b -> Map.insert b a z) mempty
|
||||
|
||||
-- | Like 'Map.insert', but returns the old value as well.
|
||||
insertLookup :: Ord k => k -> v -> Map k v -> (Maybe v, Map k v)
|
||||
insertLookup :: (Ord k) => k -> v -> Map k v -> (Maybe v, Map k v)
|
||||
insertLookup k v =
|
||||
upsertLookup (const v) k
|
||||
|
||||
-- | Invert a map's keys and values. This probably only makes sense with injective maps, but otherwise, later key/value
|
||||
-- pairs (ordered by the original map's keys) overwrite earlier ones.
|
||||
invert :: Ord v => Map k v -> Map v k
|
||||
invert :: (Ord v) => Map k v -> Map v k
|
||||
invert =
|
||||
Map.foldlWithKey' (\m k v -> Map.insert v k m) Map.empty
|
||||
|
||||
@ -94,7 +94,7 @@ upsertF f =
|
||||
Map.alterF (fmap Just . f)
|
||||
|
||||
-- | Like 'upsert', but returns the old value as well.
|
||||
upsertLookup :: Ord k => (Maybe v -> v) -> k -> Map k v -> (Maybe v, Map k v)
|
||||
upsertLookup :: (Ord k) => (Maybe v -> v) -> k -> Map k v -> (Maybe v, Map k v)
|
||||
upsertLookup f =
|
||||
upsertF (\v -> (v, f v))
|
||||
|
||||
@ -113,12 +113,12 @@ deleteLookupJust =
|
||||
Map.alterF (maybe (error (reportBug "E525283" "deleteLookupJust: element not found")) (,Nothing))
|
||||
|
||||
-- | Like 'Map.elems', but return the values as a set.
|
||||
elemsSet :: Ord v => Map k v -> Set v
|
||||
elemsSet :: (Ord v) => Map k v -> Set v
|
||||
elemsSet =
|
||||
Set.fromList . Map.elems
|
||||
|
||||
-- | Like 'Map.foldlWithKey'', but with a monadic accumulator.
|
||||
foldM :: Monad m => (acc -> k -> v -> m acc) -> acc -> Map k v -> m acc
|
||||
foldM :: (Monad m) => (acc -> k -> v -> m acc) -> acc -> Map k v -> m acc
|
||||
foldM f acc0 =
|
||||
go acc0
|
||||
where
|
||||
@ -141,7 +141,7 @@ foldMapM f =
|
||||
pure $! Map.insert k v acc
|
||||
|
||||
-- | Run a monadic action for each key/value pair in a map.
|
||||
for_ :: Monad m => Map k v -> (k -> v -> m ()) -> m ()
|
||||
for_ :: (Monad m) => Map k v -> (k -> v -> m ()) -> m ()
|
||||
for_ m f =
|
||||
go m
|
||||
where
|
||||
|
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Tuple utils.
|
||||
module Unison.Util.Tuple
|
||||
|
@ -151,7 +151,7 @@ logQuery (Sql sql params) result =
|
||||
|
||||
-- Without results
|
||||
|
||||
execute :: HasCallStack => Connection -> Sql -> IO ()
|
||||
execute :: (HasCallStack) => Connection -> Sql -> IO ()
|
||||
execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
logQuery sql Nothing
|
||||
doExecute `catch` \(exception :: Sqlite.SQLError) ->
|
||||
@ -171,7 +171,7 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
-- | Execute one or more semicolon-delimited statements.
|
||||
--
|
||||
-- This function does not support parameters, and is mostly useful for executing DDL and migrations.
|
||||
executeStatements :: HasCallStack => Connection -> Text -> IO ()
|
||||
executeStatements :: (HasCallStack) => Connection -> Text -> IO ()
|
||||
executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do
|
||||
logQuery (Sql sql []) Nothing
|
||||
Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) ->
|
||||
|
@ -138,7 +138,7 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo
|
||||
exception :: SomeSqliteExceptionReason
|
||||
}
|
||||
|
||||
throwSqliteQueryException :: HasCallStack => SqliteQueryExceptionInfo -> IO a
|
||||
throwSqliteQueryException :: (HasCallStack) => SqliteQueryExceptionInfo -> IO a
|
||||
throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do
|
||||
threadId <- myThreadId
|
||||
throwIO
|
||||
|
@ -193,7 +193,7 @@ sqlQQ input =
|
||||
Nothing -> fail ("Not in scope: " ++ Text.unpack var)
|
||||
Just name -> (,) <$> [|valuesSql $(TH.varE name)|] <*> [|foldMap Sqlite.Simple.toRow $(TH.varE name)|]
|
||||
|
||||
inSql :: Sqlite.Simple.ToField a => [a] -> Text
|
||||
inSql :: (Sqlite.Simple.ToField a) => [a] -> Text
|
||||
inSql scalars =
|
||||
Text.Builder.run ("IN (" <> b_commaSep (map (\_ -> b_qmark) scalars) <> b_rparen)
|
||||
|
||||
|
@ -66,11 +66,11 @@ newtype Transaction a
|
||||
-- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context
|
||||
deriving (Applicative, Functor, Monad) via (ReaderT Connection IO)
|
||||
|
||||
instance Monoid a => Monoid (Transaction a) where
|
||||
mempty :: Monoid a => Transaction a
|
||||
instance (Monoid a) => Monoid (Transaction a) where
|
||||
mempty :: (Monoid a) => Transaction a
|
||||
mempty = pure mempty
|
||||
|
||||
instance Semigroup a => Semigroup (Transaction a) where
|
||||
instance (Semigroup a) => Semigroup (Transaction a) where
|
||||
(<>) :: Transaction a -> Transaction a -> Transaction a
|
||||
(<>) = liftA2 (<>)
|
||||
|
||||
@ -143,7 +143,7 @@ runReadOnlyTransaction conn f =
|
||||
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||
{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
||||
|
||||
runReadOnlyTransaction_ :: HasCallStack => Connection -> IO a -> IO a
|
||||
runReadOnlyTransaction_ :: (HasCallStack) => Connection -> IO a -> IO a
|
||||
runReadOnlyTransaction_ conn action = do
|
||||
bracketOnError_
|
||||
(Connection.begin conn)
|
||||
@ -170,7 +170,7 @@ runWriteTransaction conn f =
|
||||
(runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||
{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
||||
|
||||
runWriteTransaction_ :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
|
||||
runWriteTransaction_ :: (HasCallStack) => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
|
||||
runWriteTransaction_ restore conn transaction = do
|
||||
keepTryingToBeginImmediate restore conn
|
||||
result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn)
|
||||
@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do
|
||||
pure result
|
||||
|
||||
-- @BEGIN IMMEDIATE@ until success.
|
||||
keepTryingToBeginImmediate :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO ()
|
||||
keepTryingToBeginImmediate :: (HasCallStack) => (forall x. IO x -> IO x) -> Connection -> IO ()
|
||||
keepTryingToBeginImmediate restore conn =
|
||||
let loop =
|
||||
try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case
|
||||
@ -217,7 +217,7 @@ savepoint (Transaction action) = do
|
||||
-- transaction needs to retry.
|
||||
--
|
||||
-- /Warning/: attempting to run a transaction inside a transaction will cause an exception!
|
||||
unsafeIO :: HasCallStack => IO a -> Transaction a
|
||||
unsafeIO :: (HasCallStack) => IO a -> Transaction a
|
||||
unsafeIO action =
|
||||
Transaction \_ -> action
|
||||
|
||||
@ -232,11 +232,11 @@ unsafeUnTransaction (Transaction action) =
|
||||
|
||||
-- Without results
|
||||
|
||||
execute :: HasCallStack => Sql -> Transaction ()
|
||||
execute :: (HasCallStack) => Sql -> Transaction ()
|
||||
execute s =
|
||||
Transaction \conn -> Connection.execute conn s
|
||||
|
||||
executeStatements :: HasCallStack => Text -> Transaction ()
|
||||
executeStatements :: (HasCallStack) => Text -> Transaction ()
|
||||
executeStatements s =
|
||||
Transaction \conn -> Connection.executeStatements conn s
|
||||
|
||||
|
@ -42,10 +42,8 @@ test =
|
||||
scope "<>" . expect' $
|
||||
Bytes.toArray (b1s <> b2s <> b3s) == b1 <> b2 <> b3
|
||||
scope "Ord" . expect' $
|
||||
(b1 <> b2 <> b3)
|
||||
`compare` b3
|
||||
== (b1s <> b2s <> b3s)
|
||||
`compare` b3s
|
||||
(b1 <> b2 <> b3) `compare` b3
|
||||
== (b1s <> b2s <> b3s) `compare` b3s
|
||||
scope "take" . expect' $
|
||||
Bytes.toArray (Bytes.take k (b1s <> b2s)) == BS.take k (b1 <> b2)
|
||||
scope "drop" . expect' $
|
||||
|
@ -53,9 +53,9 @@ import Data.Set.NonEmpty (NESet)
|
||||
import Data.Set.NonEmpty qualified as Set.NonEmpty
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Prelude hiding (filter)
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
import Prelude hiding (filter)
|
||||
|
||||
-- | A left-unique relation.
|
||||
--
|
||||
@ -75,32 +75,32 @@ isEmpty :: BiMultimap a b -> Bool
|
||||
isEmpty =
|
||||
Map.null . domain
|
||||
|
||||
memberDom :: Ord a => a -> BiMultimap a b -> Bool
|
||||
memberDom :: (Ord a) => a -> BiMultimap a b -> Bool
|
||||
memberDom x =
|
||||
Map.member x . domain
|
||||
|
||||
-- | Look up the set of @b@ related to an @a@.
|
||||
--
|
||||
-- /O(log a)/.
|
||||
lookupDom :: Ord a => a -> BiMultimap a b -> Set b
|
||||
lookupDom :: (Ord a) => a -> BiMultimap a b -> Set b
|
||||
lookupDom a =
|
||||
lookupDom_ a . domain
|
||||
|
||||
lookupDom_ :: Ord a => a -> Map a (NESet b) -> Set b
|
||||
lookupDom_ :: (Ord a) => a -> Map a (NESet b) -> Set b
|
||||
lookupDom_ x xs =
|
||||
maybe Set.empty Set.NonEmpty.toSet (Map.lookup x xs)
|
||||
|
||||
-- | Look up the @a@ related to a @b@.
|
||||
--
|
||||
-- /O(log b)/.
|
||||
lookupRan :: Ord b => b -> BiMultimap a b -> Maybe a
|
||||
lookupRan :: (Ord b) => b -> BiMultimap a b -> Maybe a
|
||||
lookupRan b (BiMultimap _ r) =
|
||||
Map.lookup b r
|
||||
|
||||
-- | Look up the @a@ related to a @b@.
|
||||
--
|
||||
-- /O(log b)/.
|
||||
unsafeLookupRan :: Ord b => b -> BiMultimap a b -> a
|
||||
unsafeLookupRan :: (Ord b) => b -> BiMultimap a b -> a
|
||||
unsafeLookupRan b (BiMultimap _ r) =
|
||||
r Map.! b
|
||||
|
||||
@ -175,11 +175,11 @@ range = toMapR
|
||||
|
||||
-- | Construct a left-unique relation from a mapping from its left-elements to set-of-right-elements. The caller is
|
||||
-- responsible for ensuring that no right-element is mapped to by two different left-elements.
|
||||
unsafeFromDomain :: Ord b => Map a (NESet b) -> BiMultimap a b
|
||||
unsafeFromDomain :: (Ord b) => Map a (NESet b) -> BiMultimap a b
|
||||
unsafeFromDomain domain =
|
||||
BiMultimap domain (invertDomain domain)
|
||||
|
||||
invertDomain :: forall a b. Ord b => Map a (NESet b) -> Map b a
|
||||
invertDomain :: forall a b. (Ord b) => Map a (NESet b) -> Map b a
|
||||
invertDomain =
|
||||
Map.foldlWithKey' f Map.empty
|
||||
where
|
||||
@ -234,7 +234,7 @@ insert a b m@(BiMultimap l r) =
|
||||
l' = Map.upsert (maybe (Set.NonEmpty.singleton b) (Set.NonEmpty.insert b)) a l
|
||||
|
||||
-- @upsertFunc x@ returns a function that upserts @x@, suitable for passing to @Map.alterF@.
|
||||
upsertFunc :: Eq a => a -> Maybe a -> (UpsertResult a, Maybe a)
|
||||
upsertFunc :: (Eq a) => a -> Maybe a -> (UpsertResult a, Maybe a)
|
||||
upsertFunc new existing =
|
||||
case existing of
|
||||
Nothing -> (Inserted, Just new)
|
||||
@ -266,7 +266,7 @@ unsafeUnion xs ys =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
-- @deriveRangeFromDomain x ys range@ is a helper that inserts @(x, y1)@, @(x, y2)@, ... into range @r@.
|
||||
deriveRangeFromDomain :: Ord b => a -> NESet b -> Map b a -> Map b a
|
||||
deriveRangeFromDomain :: (Ord b) => a -> NESet b -> Map b a -> Map b a
|
||||
deriveRangeFromDomain x ys acc =
|
||||
foldr (flip Map.insert x) acc ys
|
||||
{-# INLINE deriveRangeFromDomain #-}
|
||||
|
@ -12,15 +12,30 @@
|
||||
# https://github.com/input-output-hk/haskell.nix/issues/1793
|
||||
# https://github.com/input-output-hk/haskell.nix/issues/1885
|
||||
allToolDeps = false;
|
||||
additional = hpkgs: with hpkgs; [Cabal stm exceptions ghc ghc-heap];
|
||||
buildInputs = let
|
||||
native-packages =
|
||||
lib.optionals pkgs.stdenv.isDarwin
|
||||
(with pkgs.darwin.apple_sdk.frameworks; [Cocoa]);
|
||||
in
|
||||
|
||||
additional = hpkgs:
|
||||
(args.additional or (_: [])) hpkgs
|
||||
++ [
|
||||
hpkgs.Cabal
|
||||
hpkgs.exceptions
|
||||
hpkgs.ghc
|
||||
hpkgs.ghc-heap
|
||||
hpkgs.stm
|
||||
];
|
||||
buildInputs =
|
||||
(args.buildInputs or [])
|
||||
++ [pkgs.stack-wrapped pkgs.hpack pkgs.pkg-config pkgs.zlib pkgs.glibcLocales]
|
||||
++ native-packages;
|
||||
++ [
|
||||
pkgs.glibcLocales
|
||||
pkgs.zlib
|
||||
];
|
||||
nativeBuildInputs =
|
||||
(args.nativeBuildInputs or [])
|
||||
++ [
|
||||
pkgs.cachix
|
||||
pkgs.hpack
|
||||
pkgs.pkg-config
|
||||
pkgs.stack-wrapped
|
||||
];
|
||||
# workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/11042
|
||||
shellHook = ''
|
||||
export LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH
|
||||
|
@ -78,7 +78,7 @@ instance (Applicative m) => Semigroup (TreeDiff m) where
|
||||
instance (Applicative m) => Monoid (TreeDiff m) where
|
||||
mempty = TreeDiff (mempty :< Compose mempty)
|
||||
|
||||
hoistTreeDiff :: Functor m => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n
|
||||
hoistTreeDiff :: (Functor m) => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n
|
||||
hoistTreeDiff f (TreeDiff cfr) =
|
||||
TreeDiff $ Cofree.hoistCofree (\(Compose m) -> Compose (fmap f m)) cfr
|
||||
|
||||
|
@ -174,13 +174,13 @@ rewriteCaseRef = lookupDeclRef "RewriteCase"
|
||||
pattern RewriteCase' :: Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
|
||||
pattern RewriteCase' lhs rhs <- (unRewriteCase -> Just (lhs, rhs))
|
||||
|
||||
rewriteCase :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
|
||||
rewriteCase :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
|
||||
rewriteCase a tm1 tm2 = Term.app a (Term.app a1 (Term.constructor a1 r) tm1) tm2
|
||||
where
|
||||
a1 = ABT.annotation tm1
|
||||
r = ConstructorReference rewriteCaseRef 0
|
||||
|
||||
rewriteTerm :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
|
||||
rewriteTerm :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
|
||||
rewriteTerm a tm1 tm2 = Term.app a (Term.app a1 (Term.constructor a1 r) tm1) tm2
|
||||
where
|
||||
a1 = ABT.annotation tm1
|
||||
|
@ -396,12 +396,9 @@ typeLookupForDependencies codebase s = do
|
||||
unseen :: TL.TypeLookup Symbol a -> Reference -> Bool
|
||||
unseen tl r =
|
||||
isNothing
|
||||
( Map.lookup r (TL.dataDecls tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.typeOfTerms tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl)
|
||||
$> ()
|
||||
( Map.lookup r (TL.dataDecls tl) $> ()
|
||||
<|> Map.lookup r (TL.typeOfTerms tl) $> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl) $> ()
|
||||
)
|
||||
|
||||
toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
||||
|
@ -25,8 +25,8 @@ import Unison.Codebase.Branch (Branch, Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.HashQualifiedPrime (HashQualified (HashQualified, NameOnly))
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
|
@ -115,9 +115,9 @@ checkCodebaseIsUpToDate = do
|
||||
-- The highest schema that this ucm knows how to migrate to.
|
||||
pure $
|
||||
if
|
||||
| schemaVersion == Q.currentSchemaVersion -> CodebaseUpToDate
|
||||
| schemaVersion < Q.currentSchemaVersion -> CodebaseRequiresMigration schemaVersion Q.currentSchemaVersion
|
||||
| otherwise -> CodebaseUnknownSchemaVersion schemaVersion
|
||||
| schemaVersion == Q.currentSchemaVersion -> CodebaseUpToDate
|
||||
| schemaVersion < Q.currentSchemaVersion -> CodebaseRequiresMigration schemaVersion Q.currentSchemaVersion
|
||||
| otherwise -> CodebaseUnknownSchemaVersion schemaVersion
|
||||
|
||||
-- | Migrates a codebase up to the most recent version known to ucm.
|
||||
-- This is a No-op if it's up to date
|
||||
|
@ -40,7 +40,7 @@ import Unison.Var qualified as Var
|
||||
--
|
||||
-- Note that we can't actually tell whether the Decl was originally a record or not, so we
|
||||
-- include all possible accessors, but they may or may not exist in the codebase.
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors :: Var v => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors :: (Var v) => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency
|
||||
labeledDeclDependenciesIncludingSelfAndFieldAccessors selfRef decl =
|
||||
DD.labeledDeclDependenciesIncludingSelf selfRef decl
|
||||
<> case decl of
|
||||
|
@ -79,7 +79,7 @@ inferDecls ppe declMap =
|
||||
|
||||
-- | Break the decls into strongly connected components in reverse
|
||||
-- topological order
|
||||
intoComponents :: forall v a. Ord v => Map Reference (Decl v a) -> [[(Reference, Decl v a)]]
|
||||
intoComponents :: forall v a. (Ord v) => Map Reference (Decl v a) -> [[(Reference, Decl v a)]]
|
||||
intoComponents declMap =
|
||||
let graphInput :: [(Decl v a, Reference, [Reference])]
|
||||
graphInput = Map.foldrWithKey (\k a b -> (a, k, declReferences a) : b) [] declMap
|
||||
|
@ -43,7 +43,7 @@ prettyArrow prec lhs rhs =
|
||||
in wrap (lhs <> " -> " <> rhs)
|
||||
|
||||
prettyCyclicSolvedConstraint ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
Solved.Constraint (UVar v loc) v loc ->
|
||||
Int ->
|
||||
Map (UVar v loc) (P.Pretty P.ColorText) ->
|
||||
@ -62,7 +62,7 @@ prettyCyclicSolvedConstraint constraint prec nameMap visitingSet = case constrai
|
||||
pure (prettyArrow prec pa pb, cyclicLhs <> cyclicRhs)
|
||||
|
||||
prettyCyclicUVarKindWorker ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
Int ->
|
||||
UVar v loc ->
|
||||
Map (UVar v loc) (P.Pretty P.ColorText) ->
|
||||
@ -78,11 +78,11 @@ prettyCyclicUVarKindWorker prec u nameMap visitingSet =
|
||||
-- | Pretty print the kind constraint on the given @UVar@.
|
||||
--
|
||||
-- __Precondition:__ The @ConstraintMap@ is acyclic.
|
||||
prettyUVarKind :: Var v => PrettyPrintEnv -> ConstraintMap v loc -> UVar v loc -> P.Pretty P.ColorText
|
||||
prettyUVarKind :: (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> UVar v loc -> P.Pretty P.ColorText
|
||||
prettyUVarKind ppe constraints uvar = ppRunner ppe constraints do
|
||||
prettyUVarKind' arrPrec uvar
|
||||
|
||||
prettyUVarKind' :: Var v => Int -> UVar v loc -> Solve v loc (P.Pretty P.ColorText)
|
||||
prettyUVarKind' :: (Var v) => Int -> UVar v loc -> Solve v loc (P.Pretty P.ColorText)
|
||||
prettyUVarKind' prec u =
|
||||
find u >>= \case
|
||||
Nothing -> pure (prettyUnknown prec)
|
||||
@ -92,7 +92,7 @@ prettyUVarKind' prec u =
|
||||
--
|
||||
-- __Precondition:__ The @ConstraintMap@ is acyclic.
|
||||
prettySolvedConstraint ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
ConstraintMap v loc ->
|
||||
Solved.Constraint (UVar v loc) v loc ->
|
||||
@ -100,7 +100,7 @@ prettySolvedConstraint ::
|
||||
prettySolvedConstraint ppe constraints c =
|
||||
ppRunner ppe constraints (prettySolvedConstraint' arrPrec c)
|
||||
|
||||
prettySolvedConstraint' :: Var v => Int -> Solved.Constraint (UVar v loc) v loc -> Solve v loc (P.Pretty P.ColorText)
|
||||
prettySolvedConstraint' :: (Var v) => Int -> Solved.Constraint (UVar v loc) v loc -> Solve v loc (P.Pretty P.ColorText)
|
||||
prettySolvedConstraint' prec = \case
|
||||
Solved.IsAbility _ -> pure (prettyAbility prec)
|
||||
Solved.IsType _ -> pure (prettyType prec)
|
||||
@ -113,7 +113,7 @@ prettySolvedConstraint' prec = \case
|
||||
-- constraint map, but no constraints are added. This runner just
|
||||
-- allows running pretty printers outside of the @Solve@ monad by
|
||||
-- discarding the resulting state.
|
||||
ppRunner :: Var v => PrettyPrintEnv -> ConstraintMap v loc -> (forall r. Solve v loc r -> r)
|
||||
ppRunner :: (Var v) => PrettyPrintEnv -> ConstraintMap v loc -> (forall r. Solve v loc r -> r)
|
||||
ppRunner ppe constraints =
|
||||
let st =
|
||||
SolveState
|
||||
@ -130,7 +130,7 @@ ppRunner ppe constraints =
|
||||
--
|
||||
-- __Precondition:__ The @UVar@ has a cyclic constraint.
|
||||
prettyCyclicUVarKind ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
ConstraintMap v loc ->
|
||||
UVar v loc ->
|
||||
|
@ -28,7 +28,7 @@ data ConstraintConflict v loc = ConstraintConflict'
|
||||
conflictedConstraint :: Solved.Constraint (UVar v loc) v loc
|
||||
}
|
||||
|
||||
lspLoc :: Semigroup loc => KindError v loc -> loc
|
||||
lspLoc :: (Semigroup loc) => KindError v loc -> loc
|
||||
lspLoc = \case
|
||||
CycleDetected loc _ _ -> loc
|
||||
UnexpectedArgument _ abs arg _ -> varLoc abs <> varLoc arg
|
||||
@ -45,30 +45,30 @@ data KindError v loc
|
||||
CycleDetected loc (UVar v loc) (ConstraintMap v loc)
|
||||
| -- | Something of kind * or Effect is applied to an argument
|
||||
UnexpectedArgument
|
||||
-- | src span of abs
|
||||
loc
|
||||
-- ^ src span of abs
|
||||
-- | abs var
|
||||
(UVar v loc)
|
||||
-- ^ abs var
|
||||
-- | arg var
|
||||
(UVar v loc)
|
||||
-- ^ arg var
|
||||
(ConstraintMap v loc)
|
||||
-- ^ context
|
||||
-- | context
|
||||
-- | An arrow kind is applied to a type, but its kind doesn't match
|
||||
-- the expected argument kind
|
||||
| ArgumentMismatch
|
||||
(UVar v loc)
|
||||
-- ^ abs var
|
||||
(UVar v loc)
|
||||
-- ^ expected var
|
||||
(UVar v loc)
|
||||
-- ^ given var
|
||||
(ConstraintMap v loc)
|
||||
-- ^ context
|
||||
| ArgumentMismatch
|
||||
-- | abs var
|
||||
(UVar v loc)
|
||||
-- | expected var
|
||||
(UVar v loc)
|
||||
-- | given var
|
||||
(UVar v loc)
|
||||
-- | context
|
||||
-- | Same as @ArgumentMismatch@, but for applications to the builtin
|
||||
-- @Arrow@ type.
|
||||
(ConstraintMap v loc)
|
||||
| ArgumentMismatchArrow
|
||||
-- | (The applied arrow range, lhs, rhs)
|
||||
(loc, Type v loc, Type v loc)
|
||||
-- ^ (The applied arrow range, lhs, rhs)
|
||||
(ConstraintConflict v loc)
|
||||
(ConstraintMap v loc)
|
||||
| -- | Something appeared in an effect list that isn't of kind Effect
|
||||
@ -77,22 +77,22 @@ data KindError v loc
|
||||
(ConstraintMap v loc)
|
||||
| -- | Generic constraint conflict
|
||||
ConstraintConflict
|
||||
-- | Failed to add this constraint
|
||||
(GeneratedConstraint v loc)
|
||||
-- ^ Failed to add this constraint
|
||||
-- | Due to this conflict
|
||||
(ConstraintConflict v loc)
|
||||
-- ^ Due to this conflict
|
||||
-- | in this context
|
||||
(ConstraintMap v loc)
|
||||
-- ^ in this context
|
||||
|
||||
-- | Transform generic constraint conflicts into more specific error
|
||||
-- by examining its @ConstraintContext@.
|
||||
improveError :: Var v => KindError v loc -> Solve v loc (KindError v loc)
|
||||
improveError :: (Var v) => KindError v loc -> Solve v loc (KindError v loc)
|
||||
improveError = \case
|
||||
ConstraintConflict a b c -> improveError' a b c
|
||||
e -> pure e
|
||||
|
||||
improveError' ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
GeneratedConstraint v loc ->
|
||||
ConstraintConflict v loc ->
|
||||
ConstraintMap v loc ->
|
||||
|
@ -17,7 +17,7 @@ import Unison.Var (Var)
|
||||
|
||||
-- | Pretty print a user-facing @KindError@.
|
||||
prettyKindError ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
-- | How to print types
|
||||
(Type v loc -> Pretty ColorText) ->
|
||||
-- | How to print source spans
|
||||
|
@ -106,7 +106,7 @@ typeConstraintTree resultVar term@ABT.Term {annotation, out} = do
|
||||
effConstraints <- typeConstraintTree effKind eff
|
||||
pure $ ParentConstraint (IsAbility effKind (Provenance EffectsList $ ABT.annotation eff)) effConstraints
|
||||
|
||||
handleIntroOuter :: Var v => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r
|
||||
handleIntroOuter :: (Var v) => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r
|
||||
handleIntroOuter v loc k = do
|
||||
let typ = Type.var loc v
|
||||
new <- freshVar typ
|
||||
@ -171,7 +171,7 @@ dfAnns annAlg cons nil = ABT.cata \ann abt0 -> case abt0 of
|
||||
-- Our rewrite signature machinery generates type annotations that are
|
||||
-- not well kinded. Work around this for now by stripping those
|
||||
-- annotations.
|
||||
hackyStripAnns :: Ord v => Term.Term v loc -> Term.Term v loc
|
||||
hackyStripAnns :: (Ord v) => Term.Term v loc -> Term.Term v loc
|
||||
hackyStripAnns =
|
||||
snd . ABT.cata \ann abt0 -> case abt0 of
|
||||
ABT.Var v -> (False, ABT.var ann v)
|
||||
|
@ -52,7 +52,7 @@ run :: Gen v loc a -> GenState v loc -> (a, GenState v loc)
|
||||
run (Gen ma) st0 = ma st0
|
||||
|
||||
-- | Create a unique @UVar@ associated with @typ@
|
||||
freshVar :: Var v => T.Type v loc -> Gen v loc (UVar v loc)
|
||||
freshVar :: (Var v) => T.Type v loc -> Gen v loc (UVar v loc)
|
||||
freshVar typ = do
|
||||
st@GenState {unifVars, newVars} <- get
|
||||
let var :: Symbol
|
||||
@ -63,7 +63,7 @@ freshVar typ = do
|
||||
pure uvar
|
||||
|
||||
-- | Associate a fresh @UVar@ with @t@, push onto context
|
||||
pushType :: Var v => T.Type v loc -> Gen v loc (UVar v loc)
|
||||
pushType :: (Var v) => T.Type v loc -> Gen v loc (UVar v loc)
|
||||
pushType t = do
|
||||
GenState {typeMap} <- get
|
||||
(var, newTypeMap) <-
|
||||
@ -75,13 +75,13 @@ pushType t = do
|
||||
pure var
|
||||
|
||||
-- | Lookup the @UVar@ associated with a @Type@
|
||||
lookupType :: Var v => T.Type v loc -> Gen v loc (Maybe (UVar v loc))
|
||||
lookupType :: (Var v) => T.Type v loc -> Gen v loc (Maybe (UVar v loc))
|
||||
lookupType t = do
|
||||
GenState {typeMap} <- get
|
||||
pure (NonEmpty.head <$> Map.lookup t typeMap)
|
||||
|
||||
-- | Remove a @Type@ from the context
|
||||
popType :: Var v => T.Type v loc -> Gen v loc ()
|
||||
popType :: (Var v) => T.Type v loc -> Gen v loc ()
|
||||
popType t = do
|
||||
modify \st -> st {typeMap = del (typeMap st)}
|
||||
where
|
||||
@ -94,7 +94,7 @@ popType t = do
|
||||
in Map.alter f t m
|
||||
|
||||
-- | Helper to run an action with the given @Type@ in the context
|
||||
scopedType :: Var v => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r
|
||||
scopedType :: (Var v) => T.Type v loc -> (UVar v loc -> Gen v loc r) -> Gen v loc r
|
||||
scopedType t m = do
|
||||
s <- pushType t
|
||||
r <- m s
|
||||
|
@ -89,7 +89,7 @@ step e st cs =
|
||||
Right () -> Right finalState
|
||||
|
||||
-- | Default any unconstrained vars to @Type@
|
||||
defaultUnconstrainedVars :: Var v => SolveState v loc -> SolveState v loc
|
||||
defaultUnconstrainedVars :: (Var v) => SolveState v loc -> SolveState v loc
|
||||
defaultUnconstrainedVars st =
|
||||
let newConstraints = foldl' phi (constraints st) (newUnifVars st)
|
||||
phi b a = U.alter a handleNothing handleJust b
|
||||
@ -167,8 +167,7 @@ reduce cs0 = dbg "reduce" cs0 (go False [])
|
||||
-- contradictory constraint.
|
||||
addConstraint ::
|
||||
forall v loc.
|
||||
Ord loc =>
|
||||
Var v =>
|
||||
(Ord loc, Var v) =>
|
||||
GeneratedConstraint v loc ->
|
||||
Solve v loc (Either (KindError v loc) ())
|
||||
addConstraint constraint = do
|
||||
@ -200,8 +199,7 @@ addConstraint constraint = do
|
||||
-- satisfied.
|
||||
addConstraint' ::
|
||||
forall v loc.
|
||||
Ord loc =>
|
||||
Var v =>
|
||||
(Ord loc, Var v) =>
|
||||
UnsolvedConstraint v loc ->
|
||||
Solve v loc (Either (ConstraintConflict v loc) [UnsolvedConstraint v loc])
|
||||
addConstraint' = \case
|
||||
@ -304,7 +302,7 @@ union _unionLoc a b = do
|
||||
-- | Do an occurence check and return an error or the resulting solve
|
||||
-- state
|
||||
verify ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
SolveState v loc ->
|
||||
Either (NonEmpty (KindError v loc)) (SolveState v loc)
|
||||
verify st =
|
||||
@ -347,7 +345,7 @@ assertGen gen = do
|
||||
-- | occurence check and report any errors
|
||||
occCheck ::
|
||||
forall v loc.
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
ConstraintMap v loc ->
|
||||
Either (NonEmpty (KindError v loc)) (ConstraintMap v loc)
|
||||
occCheck constraints0 =
|
||||
@ -401,7 +399,7 @@ data OccCheckState v loc = OccCheckState
|
||||
kindErrors :: [KindError v loc]
|
||||
}
|
||||
|
||||
markVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) CycleCheck
|
||||
markVisiting :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) CycleCheck
|
||||
markVisiting x = do
|
||||
OccCheckState {visitingSet, visitingStack} <- M.get
|
||||
case Set.member x visitingSet of
|
||||
@ -420,7 +418,7 @@ markVisiting x = do
|
||||
}
|
||||
pure NoCycle
|
||||
|
||||
unmarkVisiting :: Var v => UVar v loc -> M.State (OccCheckState v loc) ()
|
||||
unmarkVisiting :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) ()
|
||||
unmarkVisiting x = M.modify \st ->
|
||||
st
|
||||
{ visitingSet = Set.delete x (visitingSet st),
|
||||
@ -431,7 +429,7 @@ unmarkVisiting x = M.modify \st ->
|
||||
addError :: KindError v loc -> M.State (OccCheckState v loc) ()
|
||||
addError ke = M.modify \st -> st {kindErrors = ke : kindErrors st}
|
||||
|
||||
isSolved :: Var v => UVar v loc -> M.State (OccCheckState v loc) Bool
|
||||
isSolved :: (Var v) => UVar v loc -> M.State (OccCheckState v loc) Bool
|
||||
isSolved x = do
|
||||
OccCheckState {solvedSet} <- M.get
|
||||
pure $ Set.member x solvedSet
|
||||
@ -444,7 +442,7 @@ data CycleCheck
|
||||
-- Debug output helpers
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
prettyConstraintD' :: Show loc => Var v => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText
|
||||
prettyConstraintD' :: (Show loc, Var v) => PrettyPrintEnv -> UnsolvedConstraint v loc -> P.Pretty P.ColorText
|
||||
prettyConstraintD' ppe =
|
||||
P.wrap . \case
|
||||
Unsolved.IsType v p -> prettyUVar ppe v <> " ~ Type" <> prettyProv p
|
||||
@ -455,10 +453,10 @@ prettyConstraintD' ppe =
|
||||
prettyProv x =
|
||||
"[" <> P.string (show x) <> "]"
|
||||
|
||||
prettyConstraints :: Show loc => Var v => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText
|
||||
prettyConstraints :: (Show loc, Var v) => PrettyPrintEnv -> [UnsolvedConstraint v loc] -> P.Pretty P.ColorText
|
||||
prettyConstraints ppe = P.sep "\n" . map (prettyConstraintD' ppe)
|
||||
|
||||
prettyUVar :: Var v => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText
|
||||
prettyUVar :: (Var v) => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText
|
||||
prettyUVar ppe (UVar s t) = TP.pretty ppe t <> " :: " <> P.prettyVar s
|
||||
|
||||
tracePretty :: P.Pretty P.ColorText -> a -> a
|
||||
|
@ -88,7 +88,7 @@ genStateL f st =
|
||||
}
|
||||
|
||||
-- | Interleave constraint generation into constraint solving
|
||||
runGen :: Var v => Gen v loc a -> Solve v loc a
|
||||
runGen :: (Var v) => Gen v loc a -> Solve v loc a
|
||||
runGen gena = do
|
||||
st <- M.get
|
||||
let gena' = do
|
||||
@ -104,7 +104,7 @@ runGen gena = do
|
||||
-- | Add a unification variable to the constarint mapping with no
|
||||
-- constraints. This is done on uvars created during constraint
|
||||
-- generation to initialize the new uvars (see 'runGen').
|
||||
addUnconstrainedVar :: Var v => UVar v loc -> Solve v loc ()
|
||||
addUnconstrainedVar :: (Var v) => UVar v loc -> Solve v loc ()
|
||||
addUnconstrainedVar uvar = do
|
||||
st@SolveState {constraints} <- M.get
|
||||
let constraints' = U.insert uvar Descriptor {descriptorConstraint = Nothing} constraints
|
||||
@ -125,7 +125,7 @@ emptyState =
|
||||
}
|
||||
|
||||
-- | Lookup the constraints associated with a unification variable
|
||||
find :: Var v => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc))
|
||||
find :: (Var v) => UVar v loc -> Solve v loc (Maybe (Constraint (UVar v loc) v loc))
|
||||
find k = do
|
||||
st@SolveState {constraints} <- M.get
|
||||
case U.lookupCanon k constraints of
|
||||
|
@ -81,5 +81,5 @@ unsafeParseFileBuiltinsOnly =
|
||||
names = Builtin.names
|
||||
}
|
||||
|
||||
unsafeParseFile :: Monad m => String -> Parser.ParsingEnv m -> m (UnisonFile Symbol Ann)
|
||||
unsafeParseFile :: (Monad m) => String -> Parser.ParsingEnv m -> m (UnisonFile Symbol Ann)
|
||||
unsafeParseFile s pEnv = unsafeGetRightFrom s <$> parseFile "" s pEnv
|
||||
|
@ -39,20 +39,20 @@ data Constraint vt v loc
|
||||
NegLit v PmLit
|
||||
| -- | Positive constraint on list element with position relative to head of list
|
||||
PosListHead
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | cons position (0 is head)
|
||||
Int
|
||||
-- ^ cons position (0 is head)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
| -- | Positive constraint on list element with position relative to end of list
|
||||
PosListTail
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | snoc position (0 is last)
|
||||
Int
|
||||
-- ^ snoc position (0 is last)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
| -- | Negative constraint on length of the list (/i.e./ the list
|
||||
-- may not be an element of the interval set)
|
||||
NegListInterval v IntervalSet
|
||||
|
@ -43,21 +43,21 @@ data Literal vt v loc
|
||||
NegLit v PmLit
|
||||
| -- | Positive constraint on list element with position relative to head of list
|
||||
PosListHead
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | cons position (0 is head)
|
||||
Int
|
||||
-- ^ cons position (0 is head)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
(Type vt loc)
|
||||
| -- | Positive constraint on list element with position relative to end of list
|
||||
PosListTail
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | snoc position (0 is last)
|
||||
Int
|
||||
-- ^ snoc position (0 is last)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
(Type vt loc)
|
||||
| -- | Negative constraint on length of the list (/i.e./ the list
|
||||
-- may not be an element of the interval set)
|
||||
|
@ -216,14 +216,14 @@ data VarConstraints vt v loc
|
||||
| Vc'Text (Maybe Text) (Set Text)
|
||||
| Vc'Char (Maybe Char) (Set Char)
|
||||
| Vc'ListRoot
|
||||
-- | type of list elems
|
||||
(Type vt loc)
|
||||
-- ^ type of list elems
|
||||
-- | Positive constraint on cons elements
|
||||
(Seq v)
|
||||
-- ^ Positive constraint on cons elements
|
||||
-- | Positive constraint on snoc elements
|
||||
(Seq v)
|
||||
-- ^ Positive constraint on snoc elements
|
||||
-- | positive constraint on input list size
|
||||
IntervalSet
|
||||
-- ^ positive constraint on input list size
|
||||
deriving stock (Show, Eq, Ord, Generic)
|
||||
|
||||
data EffectInfo
|
||||
|
@ -17,39 +17,39 @@ data
|
||||
loc -- annotation
|
||||
= -- | @PmCon x Con xs ys@ corresponds to the constraint @Con ys <- x@
|
||||
PmCon
|
||||
-- | Variable
|
||||
v
|
||||
-- ^ Variable
|
||||
-- | Constructor
|
||||
ConstructorReference
|
||||
-- ^ Constructor
|
||||
-- | Constructor argument values and types
|
||||
[(v, Type vt loc)]
|
||||
-- ^ Constructor argument values and types
|
||||
| PmEffect
|
||||
-- | Variable
|
||||
v
|
||||
-- ^ Variable
|
||||
-- | Constructor
|
||||
ConstructorReference
|
||||
-- ^ Constructor
|
||||
-- | Constructor argument values and types
|
||||
[(v, Type vt loc)]
|
||||
-- ^ Constructor argument values and types
|
||||
| PmEffectPure v (v, Type vt loc)
|
||||
| PmLit v PmLit
|
||||
| PmListHead
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | cons position (0 is head)
|
||||
Int
|
||||
-- ^ cons position (0 is head)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
-- | element type
|
||||
(Type vt loc)
|
||||
-- ^ element type
|
||||
| PmListTail
|
||||
-- | list root
|
||||
v
|
||||
-- ^ list root
|
||||
-- | snoc position (0 is last)
|
||||
Int
|
||||
-- ^ snoc position (0 is last)
|
||||
-- | element variable
|
||||
v
|
||||
-- ^ element variable
|
||||
-- | element type
|
||||
(Type vt loc)
|
||||
-- ^ element type
|
||||
| -- | The size of the list must fall within this inclusive range
|
||||
PmListInterval v Int Int
|
||||
| -- | If a guard performs an effect
|
||||
|
@ -39,7 +39,7 @@ pattern Result notes may = MaybeT (WriterT (Identity (may, notes)))
|
||||
|
||||
{-# COMPLETE Result #-}
|
||||
|
||||
makeResult :: Applicative m => notes -> Maybe a -> ResultT notes m a
|
||||
makeResult :: (Applicative m) => notes -> Maybe a -> ResultT notes m a
|
||||
makeResult notes value =
|
||||
MaybeT (WriterT (pure (value, notes)))
|
||||
|
||||
|
@ -1909,15 +1909,16 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
|
||||
[] <- vs =
|
||||
AccumText Nothing . Map.singleton (Util.Text.fromText t) <$> anfBody bd
|
||||
| P.Constructor _ (ConstructorReference r t) ps <- p = do
|
||||
(,) <$> expandBindings ps vs <*> anfBody bd <&> \(us, bd) ->
|
||||
AccumData r Nothing
|
||||
. EC.mapSingleton (fromIntegral t)
|
||||
. (BX <$ us,)
|
||||
. ABTN.TAbss us
|
||||
$ bd
|
||||
(,)
|
||||
<$> expandBindings ps vs
|
||||
<*> anfBody bd
|
||||
<&> \(us, bd) ->
|
||||
AccumData r Nothing . EC.mapSingleton (fromIntegral t) . (BX <$ us,) $ ABTN.TAbss us bd
|
||||
| P.EffectPure _ q <- p =
|
||||
(,) <$> expandBindings [q] vs <*> anfBody bd <&> \(us, bd) ->
|
||||
AccumPure $ ABTN.TAbss us bd
|
||||
(,)
|
||||
<$> expandBindings [q] vs
|
||||
<*> anfBody bd
|
||||
<&> \(us, bd) -> AccumPure $ ABTN.TAbss us bd
|
||||
| P.EffectBind _ (ConstructorReference r t) ps pk <- p = do
|
||||
(,,)
|
||||
<$> expandBindings (snoc ps pk) vs
|
||||
@ -1934,8 +1935,7 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
|
||||
. (BX <$ us,)
|
||||
. ABTN.TAbss us
|
||||
. TShift r kf
|
||||
. TName uk (Left jn) [kf]
|
||||
$ bd
|
||||
$ TName uk (Left jn) [kf] bd
|
||||
| P.SequenceLiteral _ [] <- p =
|
||||
AccumSeqEmpty <$> anfBody bd
|
||||
| P.SequenceOp _ l op r <- p,
|
||||
@ -1985,7 +1985,7 @@ blitLinks :: (Monoid a) => (Bool -> Reference -> a) -> BLit -> a
|
||||
blitLinks f (List s) = foldMap (valueLinks f) s
|
||||
blitLinks _ _ = mempty
|
||||
|
||||
groupTermLinks :: Var v => SuperGroup v -> [Reference]
|
||||
groupTermLinks :: (Var v) => SuperGroup v -> [Reference]
|
||||
groupTermLinks = Set.toList . foldGroupLinks f
|
||||
where
|
||||
f False r = Set.singleton r
|
||||
|
@ -19,7 +19,7 @@ import Unison.Runtime.ANF.Serialize as ANF
|
||||
import Unison.Var (Var)
|
||||
|
||||
checkGroupHashes ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
[(Referent, SuperGroup v)] ->
|
||||
Either (Text, [Referent]) (Either [Referent] [Referent])
|
||||
checkGroupHashes rgs = case checkMissing rgs of
|
||||
@ -32,7 +32,7 @@ checkGroupHashes rgs = case checkMissing rgs of
|
||||
Right ms -> Right (Left $ Ref <$> ms)
|
||||
|
||||
rehashGroups ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
Map.Map Reference (SuperGroup v) ->
|
||||
Either (Text, [Referent]) (Map.Map Reference Reference, Map.Map Reference (SuperGroup v))
|
||||
rehashGroups m
|
||||
@ -56,7 +56,7 @@ rehashGroups m
|
||||
(rm, sgs) = rehashSCC scc
|
||||
|
||||
checkMissing ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
[(Referent, SuperGroup v)] ->
|
||||
Either (Text, [Referent]) [Reference]
|
||||
checkMissing (unzip -> (rs, gs)) = do
|
||||
@ -74,7 +74,7 @@ checkMissing (unzip -> (rs, gs)) = do
|
||||
p _ _ = False
|
||||
|
||||
rehashSCC ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
SCC (Reference, SuperGroup v) ->
|
||||
(Map.Map Reference Reference, Map.Map Reference (SuperGroup v))
|
||||
rehashSCC scc
|
||||
|
@ -19,8 +19,8 @@ import Data.Sequence qualified as Seq
|
||||
import Data.Serialize.Put (runPutLazy)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word16, Word32, Word64)
|
||||
import GHC.Stack
|
||||
import GHC.IsList qualified (fromList)
|
||||
import GHC.Stack
|
||||
import Unison.ABT.Normalized (Term (..))
|
||||
import Unison.Reference (Reference, Reference' (Builtin), pattern Derived)
|
||||
import Unison.Runtime.ANF as ANF hiding (Tag)
|
||||
@ -948,7 +948,7 @@ serializeGroup fops sg = runPutS (putVersion *> putGroup mempty fops sg)
|
||||
-- Supplying a `Builtin` reference is not supported. Such code
|
||||
-- shouldn't be subject to rehashing.
|
||||
serializeGroupForRehash ::
|
||||
Var v =>
|
||||
(Var v) =>
|
||||
EC.EnumMap FOp Text ->
|
||||
Reference ->
|
||||
SuperGroup v ->
|
||||
@ -962,7 +962,7 @@ serializeGroupForRehash fops (Derived h _) sg =
|
||||
f _ = Nothing
|
||||
refrep = Map.fromList . mapMaybe f $ groupTermLinks sg
|
||||
|
||||
getVersionedValue :: MonadGet m => m Value
|
||||
getVersionedValue :: (MonadGet m) => m Value
|
||||
getVersionedValue = getVersion >>= getValue
|
||||
where
|
||||
getVersion =
|
||||
|
@ -56,7 +56,7 @@ import Data.Primitive.PrimArray as EPA hiding
|
||||
import Data.Primitive.PrimArray qualified as PA
|
||||
import Data.Primitive.Types
|
||||
import Data.Word (Word8)
|
||||
import GHC.IsList (toList )
|
||||
import GHC.IsList (toList)
|
||||
|
||||
#ifdef ARRAY_CHECK
|
||||
import GHC.Stack
|
||||
|
@ -18,7 +18,7 @@ instance Exception RuntimeExn
|
||||
die :: (HasCallStack) => String -> IO a
|
||||
die = throwIO . PE callStack . P.lit . fromString
|
||||
|
||||
dieP :: HasCallStack => P.Pretty P.ColorText -> IO a
|
||||
dieP :: (HasCallStack) => P.Pretty P.ColorText -> IO a
|
||||
dieP = throwIO . PE callStack
|
||||
|
||||
exn :: (HasCallStack) => String -> a
|
||||
|
@ -505,7 +505,7 @@ interpEval activeThreads cleanupThreads ctxVar cl ppe tm =
|
||||
evalInContext ppe ctx activeThreads initw
|
||||
`UnliftIO.finally` cleanupThreads
|
||||
|
||||
ensureExists :: HasCallStack => CreateProcess -> (CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText) -> IO ()
|
||||
ensureExists :: (HasCallStack) => CreateProcess -> (CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText) -> IO ()
|
||||
ensureExists cmd err =
|
||||
ccall >>= \case
|
||||
Nothing -> pure ()
|
||||
@ -517,13 +517,13 @@ ensureExists cmd err =
|
||||
(ExitFailure exitCode, stdout, stderr) -> pure (Just (Left (exitCode, stdout, stderr)))
|
||||
ccall = call `UnliftIO.catch` \(e :: IOException) -> pure . Just $ Right e
|
||||
|
||||
ensureRuntimeExists :: HasCallStack => FilePath -> IO ()
|
||||
ensureRuntimeExists :: (HasCallStack) => FilePath -> IO ()
|
||||
ensureRuntimeExists executable =
|
||||
ensureExists cmd runtimeErrMsg
|
||||
where
|
||||
cmd = proc executable ["--help"]
|
||||
|
||||
ensureRacoExists :: HasCallStack => IO ()
|
||||
ensureRacoExists :: (HasCallStack) => IO ()
|
||||
ensureRacoExists = ensureExists (shell "raco help") racoErrMsg
|
||||
|
||||
prettyCmdSpec :: CmdSpec -> Pretty ColorText
|
||||
|
@ -117,11 +117,7 @@ getLength = unVarInt <$> deserialize
|
||||
-- Checks for negatives, in case you put an Integer, which does not
|
||||
-- behave properly for negative numbers.
|
||||
putPositive ::
|
||||
MonadPut m =>
|
||||
Bits n =>
|
||||
Bits (Unsigned n) =>
|
||||
Integral n =>
|
||||
Integral (Unsigned n) =>
|
||||
(MonadPut m, Bits n, Bits (Unsigned n), Integral n, Integral (Unsigned n)) =>
|
||||
n ->
|
||||
m ()
|
||||
putPositive n
|
||||
@ -130,12 +126,7 @@ putPositive n
|
||||
|
||||
-- Reads as an Integer, then checks that the result will fit in the
|
||||
-- result type.
|
||||
getPositive ::
|
||||
forall m n.
|
||||
Bounded n =>
|
||||
Integral n =>
|
||||
MonadGet m =>
|
||||
m n
|
||||
getPositive :: forall m n. (Bounded n, Integral n, MonadGet m) => m n
|
||||
getPositive = validate . unVarInt =<< deserialize
|
||||
where
|
||||
mx0 :: n
|
||||
|
@ -125,7 +125,7 @@ file = do
|
||||
|
||||
-- | Final validations and sanity checks to perform before finishing parsing.
|
||||
validateUnisonFile ::
|
||||
Ord v =>
|
||||
(Ord v) =>
|
||||
Map v (TypeReferenceId, DataDeclaration v Ann) ->
|
||||
Map v (TypeReferenceId, EffectDeclaration v Ann) ->
|
||||
[(v, Ann, Term v Ann)] ->
|
||||
@ -139,7 +139,7 @@ validateUnisonFile datas effects terms watches =
|
||||
-- constructors and verify that no duplicates exist in the file, triggering an error if needed.
|
||||
checkForDuplicateTermsAndConstructors ::
|
||||
forall m v.
|
||||
Ord v =>
|
||||
(Ord v) =>
|
||||
Map v (TypeReferenceId, DataDeclaration v Ann) ->
|
||||
Map v (TypeReferenceId, EffectDeclaration v Ann) ->
|
||||
[(v, Ann, Term v Ann)] ->
|
||||
|
@ -1011,12 +1011,9 @@ force = P.label "force" $ P.try do
|
||||
|
||||
seqOp :: (Ord v) => P v m Pattern.SeqOp
|
||||
seqOp =
|
||||
Pattern.Snoc
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment)))
|
||||
<|> Pattern.Cons
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
|
||||
<|> Pattern.Concat
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
|
||||
Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment)))
|
||||
<|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
|
||||
<|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
|
||||
|
||||
term4 :: (Monad m, Var v) => TermP v m
|
||||
term4 = f <$> some termLeaf
|
||||
|
@ -969,7 +969,7 @@ prettyBinding0' a@AmbientContext {imports = im, docContext = doc} v term =
|
||||
PP.group $
|
||||
PP.group (defnLhs v vs <> fmt S.BindingEquals " = ")
|
||||
<> prettyBody
|
||||
`PP.orElse` ("\n" <> PP.indentN 2 prettyBody)
|
||||
`PP.orElse` ("\n" <> PP.indentN 2 prettyBody)
|
||||
}
|
||||
_ ->
|
||||
pure $
|
||||
@ -1532,7 +1532,7 @@ immediateChildBlockTerms = \case
|
||||
doLet (v, LamsNamedOpt' _ body) = [body | not (Var.isAction v), isLet body]
|
||||
doLet t = error (show t) []
|
||||
|
||||
isSoftHangable :: Var v => Term2 vt at ap v a -> Bool
|
||||
isSoftHangable :: (Var v) => Term2 vt at ap v a -> Bool
|
||||
-- isSoftHangable (Delay' d) = isLet d || isSoftHangable d || case d of
|
||||
-- Match' scrute cases -> isDestructuringBind scrute cases
|
||||
-- _ -> False
|
||||
@ -2160,7 +2160,7 @@ avoidShadowing tm (PrettyPrintEnv terms types) =
|
||||
& maybe fullName HQ'.NameOnly
|
||||
in (fullName, minimallySuffixed)
|
||||
tweak _ p = p
|
||||
varToName :: Var v => v -> [Name]
|
||||
varToName :: (Var v) => v -> [Name]
|
||||
varToName = toList . Name.parseText . Var.name
|
||||
|
||||
isLeaf :: Term2 vt at ap v a -> Bool
|
||||
|
@ -101,7 +101,7 @@ sequenceTyp = do
|
||||
let a = ann open <> ann close
|
||||
pure $ Type.app a (Type.list a) t
|
||||
|
||||
tupleOrParenthesizedType :: Var v => TypeP v m -> TypeP v m
|
||||
tupleOrParenthesizedType :: (Var v) => TypeP v m -> TypeP v m
|
||||
tupleOrParenthesizedType rec = do
|
||||
(spanAnn, ty) <- tupleOrParenthesized rec DD.unitType pair
|
||||
pure (ty {ABT.annotation = ABT.annotation ty <> spanAnn})
|
||||
|
@ -249,7 +249,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
|
||||
|
||||
guard x a = if x then Just a else Nothing
|
||||
|
||||
suggestedVar :: Var v => v -> Text -> v
|
||||
suggestedVar :: (Var v) => v -> Text -> v
|
||||
suggestedVar v name =
|
||||
case Var.typeOf v of
|
||||
Var.MissingResult -> v
|
||||
|
@ -606,15 +606,15 @@ debugTrace :: String -> Bool
|
||||
debugTrace e | debugEnabled = trace e False
|
||||
debugTrace _ = False
|
||||
|
||||
showType :: Var v => Type.Type v a -> String
|
||||
showType :: (Var v) => Type.Type v a -> String
|
||||
showType ty = TP.prettyStr (Just 120) PPE.empty ty
|
||||
|
||||
debugType :: Var v => String -> Type.Type v a -> Bool
|
||||
debugType :: (Var v) => String -> Type.Type v a -> Bool
|
||||
debugType tag ty
|
||||
| debugEnabled = debugTrace $ "(" <> show tag <> "," <> showType ty <> ")"
|
||||
| otherwise = False
|
||||
|
||||
debugTypes :: Var v => String -> Type.Type v a -> Type.Type v a -> Bool
|
||||
debugTypes :: (Var v) => String -> Type.Type v a -> Type.Type v a -> Bool
|
||||
debugTypes tag t1 t2
|
||||
| debugEnabled = debugTrace $ "(" <> show tag <> ",\n " <> showType t1 <> ",\n " <> showType t2 <> ")"
|
||||
| otherwise = False
|
||||
|
@ -82,7 +82,7 @@ emptyUnisonFile =
|
||||
watches = Map.empty
|
||||
}
|
||||
|
||||
leftBiasedMerge :: forall v a. Ord v => UnisonFile v a -> UnisonFile v a -> UnisonFile v a
|
||||
leftBiasedMerge :: forall v a. (Ord v) => UnisonFile v a -> UnisonFile v a -> UnisonFile v a
|
||||
leftBiasedMerge lhs rhs =
|
||||
let mergedTerms = Map.foldlWithKey' (addNotIn lhsTermNames) (terms lhs) (terms rhs)
|
||||
mergedWatches = Map.foldlWithKey' addWatch (watches lhs) (watches rhs)
|
||||
@ -344,7 +344,7 @@ dependencies (UnisonFile ds es ts ws) =
|
||||
<> foldMap (Term.dependencies . snd) ts
|
||||
<> foldMap (foldMap (Term.dependencies . view _3)) ws
|
||||
|
||||
discardTypes :: Ord v => TypecheckedUnisonFile v a -> UnisonFile v a
|
||||
discardTypes :: (Ord v) => TypecheckedUnisonFile v a -> UnisonFile v a
|
||||
discardTypes (TypecheckedUnisonFileId datas effects terms watches _) =
|
||||
let watches' = g . mconcat <$> List.multimap watches
|
||||
g tup3s = [(v, a, e) | (v, a, e, _t) <- tup3s]
|
||||
|
@ -28,7 +28,7 @@ import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.WatchKind qualified as WK
|
||||
|
||||
toNames :: Var v => UnisonFile v a -> Names
|
||||
toNames :: (Var v) => UnisonFile v a -> Names
|
||||
toNames uf = datas <> effects
|
||||
where
|
||||
datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList (UF.dataDeclarationsId uf))
|
||||
@ -106,7 +106,7 @@ bindNames names (UnisonFileId d e ts ws) = do
|
||||
--
|
||||
-- It's used below in `environmentFor` and also during the term resolution
|
||||
-- process.
|
||||
variableCanonicalizer :: forall v. Var v => [v] -> Map v v
|
||||
variableCanonicalizer :: forall v. (Var v) => [v] -> Map v v
|
||||
variableCanonicalizer vs =
|
||||
done $ List.multimap do
|
||||
v <- vs
|
||||
|
@ -140,8 +140,8 @@ indexOf needle haystack =
|
||||
ordinal :: (IsString s) => Int -> s
|
||||
ordinal n = do
|
||||
let s = show n
|
||||
fromString $ s ++
|
||||
case L.drop (L.length s - 2) s of
|
||||
fromString $
|
||||
s ++ case L.drop (L.length s - 2) s of
|
||||
['1', '1'] -> "th"
|
||||
['1', '2'] -> "th"
|
||||
['1', '3'] -> "th"
|
||||
|
@ -46,10 +46,8 @@ test =
|
||||
scope "<>" . expect' $
|
||||
Text.toText (t1s <> t2s <> t3s) == t1 <> t2 <> t3
|
||||
scope "Ord" . expect' $
|
||||
(t1 <> t2 <> t3)
|
||||
`compare` t3
|
||||
== (t1s <> t2s <> t3s)
|
||||
`compare` t3s
|
||||
(t1 <> t2 <> t3) `compare` t3
|
||||
== (t1s <> t2s <> t3s) `compare` t3s
|
||||
scope "take" . expect' $
|
||||
Text.toText (Text.take k (t1s <> t2s)) == T.take k (t1 <> t2)
|
||||
scope "drop" . expect' $
|
||||
|
@ -96,6 +96,7 @@
|
||||
(error 'blake2 "~a failed with return value ~a" fn r))))))
|
||||
|
||||
(define blake2b-raw (libb2-raw "blake2b"))
|
||||
(define blake2s-raw (libb2-raw "blake2s"))
|
||||
|
||||
(define HashAlgorithm.Md5 (lc-algo "EVP_md5" 128))
|
||||
(define HashAlgorithm.Sha1 (lc-algo "EVP_sha1" 160))
|
||||
@ -103,8 +104,6 @@
|
||||
(define HashAlgorithm.Sha2_512 (lc-algo "EVP_sha512" 512))
|
||||
(define HashAlgorithm.Sha3_256 (lc-algo "EVP_sha3_256" 256))
|
||||
(define HashAlgorithm.Sha3_512 (lc-algo "EVP_sha3_512" 512))
|
||||
(define HashAlgorithm.Blake2s_256 (lc-algo "EVP_blake2s256" 256))
|
||||
(define HashAlgorithm.Blake2b_512 (lc-algo "EVP_blake2b512" 512))
|
||||
|
||||
(define _EVP_PKEY-pointer (_cpointer 'EVP_PKEY))
|
||||
(define _EVP_MD_CTX-pointer (_cpointer 'EVP_MD_CTX))
|
||||
@ -234,6 +233,8 @@
|
||||
(chunked-bytes->bytes input)
|
||||
(chunked-bytes->bytes signature)))
|
||||
|
||||
(define (HashAlgorithm.Blake2s_256) (cons 'blake2s 256))
|
||||
(define (HashAlgorithm.Blake2b_512) (cons 'blake2b 512))
|
||||
; This one isn't provided by libcrypto, for some reason
|
||||
(define (HashAlgorithm.Blake2b_256) (cons 'blake2b 256))
|
||||
|
||||
@ -252,6 +253,7 @@
|
||||
[algo (car kind)])
|
||||
(case algo
|
||||
['blake2b (blake2b-raw output input #f bytes (bytes-length input) 0)]
|
||||
['blake2s (blake2s-raw output input #f bytes (bytes-length input) 0)]
|
||||
[else (EVP_Digest input (bytes-length input) output #f algo #f)])
|
||||
|
||||
output))
|
||||
@ -294,6 +296,7 @@
|
||||
(define (hmacBytes-raw kind key input)
|
||||
(case (car kind)
|
||||
['blake2b (hmacBlake kind key input)]
|
||||
['blake2s (hmacBlake kind key input)]
|
||||
[else
|
||||
(let* ([bytes (/ (cdr kind) 8)]
|
||||
[output (make-bytes bytes)]
|
||||
|
@ -34,7 +34,7 @@ import Unison.Sync.Types qualified as Share
|
||||
|
||||
-- | Download a project/branch from Share.
|
||||
downloadProjectBranchFromShare ::
|
||||
HasCallStack =>
|
||||
(HasCallStack) =>
|
||||
Share.IncludeSquashedHead ->
|
||||
Share.RemoteProjectBranch ->
|
||||
Cli (Either Output.ShareError CausalHash)
|
||||
|
@ -25,11 +25,11 @@ classifyConnectionError exception0 =
|
||||
HttpClient.ConnectionFailure exception1 -> do
|
||||
ioException <- fromException @IOException exception1
|
||||
if
|
||||
| -- This may not be 100% accurate... but if the initial `getAddrInfo` request fails it will indeed throw
|
||||
-- a "does not exist" error. It seems in order to *know* that `getAddrInfo` was the cause of this
|
||||
-- exception, we'd have to parse the `show` output, which is preposterous.
|
||||
isDoesNotExistError ioException ->
|
||||
Just ConnectionError'Offline
|
||||
| otherwise -> Nothing
|
||||
| -- This may not be 100% accurate... but if the initial `getAddrInfo` request fails it will indeed throw
|
||||
-- a "does not exist" error. It seems in order to *know* that `getAddrInfo` was the cause of this
|
||||
-- exception, we'd have to parse the `show` output, which is preposterous.
|
||||
isDoesNotExistError ioException ->
|
||||
Just ConnectionError'Offline
|
||||
| otherwise -> Nothing
|
||||
_ -> Nothing
|
||||
_ -> ConnectionError'SomethingEntirelyUnexpected exception0
|
||||
|
@ -262,17 +262,6 @@ loop e = do
|
||||
description <- inputDescription input
|
||||
_ <- Cli.updateAt description target (const newRoot)
|
||||
Cli.respond Success
|
||||
ResetRootI src0 ->
|
||||
Cli.time "reset-root" do
|
||||
newRoot <-
|
||||
case src0 of
|
||||
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||
BranchAtPath path' -> Cli.expectBranchAtPath' path'
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
description <- inputDescription input
|
||||
pb <- getCurrentProjectBranch
|
||||
void $ Cli.updateProjectBranchRoot_ pb description (const newRoot)
|
||||
Cli.respond Success
|
||||
ForkLocalBranchI src0 dest0 -> do
|
||||
(srcb, branchEmpty) <-
|
||||
case src0 of
|
||||
@ -908,9 +897,6 @@ inputDescription input =
|
||||
let tgtText = into @Text tgt
|
||||
pure (" " <> tgtText)
|
||||
pure ("reset " <> hashTxt <> tgt)
|
||||
ResetRootI src0 -> do
|
||||
let src = into @Text src0
|
||||
pure ("reset-root " <> src)
|
||||
AliasTermI force src0 dest0 -> do
|
||||
src <- hhqs' src0
|
||||
dest <- ps' dest0
|
||||
|
@ -5,6 +5,8 @@ module Unison.Codebase.Editor.HandleInput.DebugSynhashTerm
|
||||
where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as Text
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -22,11 +24,9 @@ import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Util.Pretty (ColorText, Pretty)
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import qualified Unison.Syntax.Name as Name
|
||||
|
||||
handleDebugSynhashTerm :: Name -> Cli ()
|
||||
handleDebugSynhashTerm name = do
|
||||
|
@ -39,7 +39,7 @@ import Unison.Var qualified as Var
|
||||
|
||||
-- | Format a file, returning a list of Text replacements to apply to the file.
|
||||
formatFile ::
|
||||
Monad m =>
|
||||
(Monad m) =>
|
||||
(Maybe (UnisonFile Symbol Ann.Ann) -> Maybe (TypecheckedUnisonFile Symbol Ann.Ann) -> m PPED.PrettyPrintEnvDecl) ->
|
||||
Int ->
|
||||
Path.Absolute ->
|
||||
@ -197,7 +197,7 @@ annToInterval ann = annToRange ann <&> rangeToInterval
|
||||
|
||||
-- | Returns 'True' if the given symbol is a term with a user provided type signature in the
|
||||
-- parsed file, false otherwise.
|
||||
hasUserTypeSignature :: Eq v => UnisonFile v a -> v -> Bool
|
||||
hasUserTypeSignature :: (Eq v) => UnisonFile v a -> v -> Bool
|
||||
hasUserTypeSignature parsedFile sym =
|
||||
Map.toList (UF.terms parsedFile)
|
||||
& any (\(v, (_, trm)) -> v == sym && isJust (Term.getTypeAnnotation trm))
|
||||
|
@ -82,12 +82,12 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} =
|
||||
q = \case
|
||||
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) ->
|
||||
if
|
||||
| ref == DD.testResultRef ->
|
||||
if
|
||||
| cid == DD.okConstructorId -> Just (Right msg)
|
||||
| cid == DD.failConstructorId -> Just (Left msg)
|
||||
| otherwise -> Nothing
|
||||
| otherwise -> Nothing
|
||||
| ref == DD.testResultRef ->
|
||||
if
|
||||
| cid == DD.okConstructorId -> Just (Right msg)
|
||||
| cid == DD.failConstructorId -> Just (Left msg)
|
||||
| otherwise -> Nothing
|
||||
| otherwise -> Nothing
|
||||
_ -> Nothing
|
||||
let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests)
|
||||
names <- Cli.currentNames
|
||||
@ -225,9 +225,9 @@ partitionTestResults tm = fold $ do
|
||||
Term.App' (Term.Constructor' (ConstructorReference conRef cid)) (Term.Text' msg) -> do
|
||||
guard (conRef == DD.testResultRef)
|
||||
if
|
||||
| cid == DD.okConstructorId -> pure (mempty, [msg])
|
||||
| cid == DD.failConstructorId -> pure ([msg], mempty)
|
||||
| otherwise -> empty
|
||||
| cid == DD.okConstructorId -> pure (mempty, [msg])
|
||||
| cid == DD.failConstructorId -> pure ([msg], mempty)
|
||||
| otherwise -> empty
|
||||
_ -> empty
|
||||
|
||||
isTestOk :: Term v Ann -> Bool
|
||||
|
@ -125,11 +125,10 @@ data Input
|
||||
| DiffNamespaceI BranchId2 BranchId2 -- old new
|
||||
| PullI !PullSourceTarget !PullMode
|
||||
| PushRemoteBranchI PushRemoteBranchInput
|
||||
| ResetRootI BranchId
|
||||
| ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -})
|
||||
-- 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
|
||||
-- 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'
|
||||
|
50
unison-cli/src/Unison/Codebase/Transcript.hs
Normal file
50
unison-cli/src/Unison/Codebase/Transcript.hs
Normal file
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- | The data model for Unison transcripts.
|
||||
module Unison.Codebase.Transcript
|
||||
( ExpectingError,
|
||||
ScratchFileName,
|
||||
Hidden (..),
|
||||
UcmLine (..),
|
||||
UcmContext (..),
|
||||
APIRequest (..),
|
||||
pattern CMarkCodeBlock,
|
||||
Stanza,
|
||||
ProcessedBlock (..),
|
||||
)
|
||||
where
|
||||
|
||||
import CMark qualified
|
||||
import Unison.Core.Project (ProjectBranchName, ProjectName)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch)
|
||||
|
||||
type ExpectingError = Bool
|
||||
|
||||
type ScratchFileName = Text
|
||||
|
||||
data Hidden = Shown | HideOutput | HideAll
|
||||
deriving (Eq, Show)
|
||||
|
||||
data UcmLine
|
||||
= UcmCommand UcmContext Text
|
||||
| -- | Text does not include the '--' prefix.
|
||||
UcmComment Text
|
||||
|
||||
-- | Where a command is run: a project branch (myproject/mybranch>).
|
||||
data UcmContext
|
||||
= UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
|
||||
|
||||
data APIRequest
|
||||
= GetRequest Text
|
||||
| APIComment Text
|
||||
|
||||
pattern CMarkCodeBlock :: (Maybe CMark.PosInfo) -> Text -> Text -> CMark.Node
|
||||
pattern CMarkCodeBlock pos info body = CMark.Node pos (CMark.CODE_BLOCK info body) []
|
||||
|
||||
type Stanza = Either CMark.Node ProcessedBlock
|
||||
|
||||
data ProcessedBlock
|
||||
= Ucm Hidden ExpectingError [UcmLine]
|
||||
| Unison Hidden ExpectingError (Maybe ScratchFileName) Text
|
||||
| API [APIRequest]
|
166
unison-cli/src/Unison/Codebase/Transcript/Parser.hs
Normal file
166
unison-cli/src/Unison/Codebase/Transcript/Parser.hs
Normal file
@ -0,0 +1,166 @@
|
||||
-- | Parse and print CommonMark (like Github-flavored Markdown) transcripts.
|
||||
module Unison.Codebase.Transcript.Parser
|
||||
( -- * printing
|
||||
formatAPIRequest,
|
||||
formatUcmLine,
|
||||
formatStanza,
|
||||
formatNode,
|
||||
formatProcessedBlock,
|
||||
|
||||
-- * conversion
|
||||
processedBlockToNode,
|
||||
|
||||
-- * parsing
|
||||
stanzas,
|
||||
ucmLine,
|
||||
apiRequest,
|
||||
fenced,
|
||||
hidden,
|
||||
expectingError,
|
||||
language,
|
||||
)
|
||||
where
|
||||
|
||||
import CMark qualified
|
||||
import Data.Char qualified as Char
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.Codebase.Transcript
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||
|
||||
formatAPIRequest :: APIRequest -> Text
|
||||
formatAPIRequest = \case
|
||||
GetRequest txt -> "GET " <> txt
|
||||
APIComment txt -> "-- " <> txt
|
||||
|
||||
formatUcmLine :: UcmLine -> Text
|
||||
formatUcmLine = \case
|
||||
UcmCommand context txt -> formatContext context <> "> " <> txt
|
||||
UcmComment txt -> "--" <> txt
|
||||
where
|
||||
formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch
|
||||
|
||||
formatStanza :: Stanza -> Text
|
||||
formatStanza = either formatNode formatProcessedBlock
|
||||
|
||||
formatNode :: CMark.Node -> Text
|
||||
formatNode = (<> "\n") . CMark.nodeToCommonmark [] Nothing
|
||||
|
||||
formatProcessedBlock :: ProcessedBlock -> Text
|
||||
formatProcessedBlock = formatNode . processedBlockToNode
|
||||
|
||||
processedBlockToNode :: ProcessedBlock -> CMark.Node
|
||||
processedBlockToNode = \case
|
||||
Ucm _ _ cmds -> CMarkCodeBlock Nothing "ucm" $ foldr ((<>) . formatUcmLine) "" cmds
|
||||
Unison _hide _ fname txt ->
|
||||
CMarkCodeBlock Nothing "unison" $ maybe txt (\fname -> Text.unlines ["---", "title: " <> fname, "---", txt]) fname
|
||||
API apiRequests -> CMarkCodeBlock Nothing "api" $ Text.unlines $ formatAPIRequest <$> apiRequests
|
||||
|
||||
type P = P.Parsec Void Text
|
||||
|
||||
stanzas :: FilePath -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza]
|
||||
stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromNode blocks) . CMark.commonmarkToNode []
|
||||
where
|
||||
stanzaFromNode :: CMark.Node -> Either (P.ParseErrorBundle Text Void) Stanza
|
||||
stanzaFromNode node = case node of
|
||||
CMarkCodeBlock _ info body -> maybe (Left node) pure <$> P.parse (fenced info) srcName body
|
||||
_ -> pure $ Left node
|
||||
|
||||
ucmLine :: P UcmLine
|
||||
ucmLine = ucmCommand <|> ucmComment
|
||||
where
|
||||
ucmCommand :: P UcmLine
|
||||
ucmCommand = do
|
||||
context <-
|
||||
P.try do
|
||||
contextString <- P.takeWhile1P Nothing (/= '>')
|
||||
context <-
|
||||
case (tryFrom @Text contextString) of
|
||||
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||
_ -> fail "expected project/branch or absolute path"
|
||||
void $ lineToken $ word ">"
|
||||
pure context
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmCommand context line
|
||||
|
||||
ucmComment :: P UcmLine
|
||||
ucmComment = do
|
||||
word "--"
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmComment line
|
||||
|
||||
apiRequest :: P APIRequest
|
||||
apiRequest = do
|
||||
apiComment <|> getRequest
|
||||
where
|
||||
getRequest = do
|
||||
word "GET"
|
||||
spaces
|
||||
path <- P.takeWhile1P Nothing (/= '\n')
|
||||
spaces
|
||||
pure (GetRequest path)
|
||||
apiComment = do
|
||||
word "--"
|
||||
comment <- P.takeWhileP Nothing (/= '\n')
|
||||
spaces
|
||||
pure (APIComment comment)
|
||||
|
||||
-- | Produce the correct parser for the code block based on the provided info string.
|
||||
fenced :: Text -> P (Maybe ProcessedBlock)
|
||||
fenced info = do
|
||||
body <- P.getInput
|
||||
P.setInput info
|
||||
fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language)
|
||||
case fenceType of
|
||||
"ucm" -> do
|
||||
hide <- hidden
|
||||
err <- expectingError
|
||||
P.setInput body
|
||||
pure . Ucm hide err <$> (spaces *> many ucmLine)
|
||||
"unison" ->
|
||||
do
|
||||
-- todo: this has to be more interesting
|
||||
-- ```unison:hide
|
||||
-- ```unison
|
||||
-- ```unison:hide:all scratch.u
|
||||
hide <- lineToken hidden
|
||||
err <- lineToken expectingError
|
||||
fileName <- optional untilSpace1
|
||||
P.setInput body
|
||||
pure . Unison hide err fileName <$> (spaces *> P.getInput)
|
||||
"api" -> do
|
||||
P.setInput body
|
||||
pure . API <$> (spaces *> many apiRequest)
|
||||
_ -> pure Nothing
|
||||
|
||||
word :: Text -> P Text
|
||||
word txt = P.try $ do
|
||||
chs <- P.takeP (Just $ show txt) (Text.length txt)
|
||||
guard (chs == txt)
|
||||
pure txt
|
||||
|
||||
lineToken :: P a -> P a
|
||||
lineToken p = p <* nonNewlineSpaces
|
||||
|
||||
nonNewlineSpaces :: P ()
|
||||
nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')
|
||||
|
||||
hidden :: P Hidden
|
||||
hidden =
|
||||
(HideAll <$ word ":hide:all")
|
||||
<|> (HideOutput <$ word ":hide")
|
||||
<|> pure Shown
|
||||
|
||||
expectingError :: P ExpectingError
|
||||
expectingError = isJust <$> optional (word ":error")
|
||||
|
||||
untilSpace1 :: P Text
|
||||
untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace)
|
||||
|
||||
language :: P Text
|
||||
language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_')
|
||||
|
||||
spaces :: P ()
|
||||
spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace
|
@ -1,30 +1,18 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{- Parse and execute markdown transcripts.
|
||||
-}
|
||||
module Unison.Codebase.TranscriptParser
|
||||
( Stanza (..),
|
||||
FenceType,
|
||||
ExpectingError,
|
||||
Hidden,
|
||||
TranscriptError (..),
|
||||
UcmLine (..),
|
||||
withTranscriptRunner,
|
||||
parse,
|
||||
parseFile,
|
||||
-- | Execute transcripts.
|
||||
module Unison.Codebase.Transcript.Runner
|
||||
( Error (..),
|
||||
Runner,
|
||||
withRunner,
|
||||
)
|
||||
where
|
||||
|
||||
import CMark qualified
|
||||
import Control.Lens (use, (?~))
|
||||
import Crypto.Random qualified as Random
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Aeson.Encode.Pretty qualified as Aeson
|
||||
import Data.ByteString.Lazy.Char8 qualified as BL
|
||||
import Data.Char qualified as Char
|
||||
import Data.Configurator qualified as Configurator
|
||||
import Data.Configurator.Types (Config)
|
||||
import Data.IORef
|
||||
@ -35,7 +23,6 @@ import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import Network.HTTP.Client qualified as HTTP
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (die)
|
||||
import System.IO qualified as IO
|
||||
@ -59,6 +46,8 @@ import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.Transcript
|
||||
import Unison.Codebase.Transcript.Parser qualified as Transcript
|
||||
import Unison.Codebase.Verbosity (Verbosity, isSilent)
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine
|
||||
@ -66,7 +55,6 @@ import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName))
|
||||
import Unison.CommandLine.InputPatterns (validInputs)
|
||||
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
|
||||
import Unison.CommandLine.Welcome (asciiartUnison)
|
||||
import Unison.Core.Project (ProjectBranchName, ProjectName (..))
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyTerminal
|
||||
@ -94,116 +82,31 @@ terminalWidth = 65
|
||||
accessTokenEnvVarKey :: String
|
||||
accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN"
|
||||
|
||||
type ExpectingError = Bool
|
||||
type Runner =
|
||||
String ->
|
||||
Text ->
|
||||
(FilePath, Codebase IO Symbol Ann) ->
|
||||
IO (Either Error Text)
|
||||
|
||||
type ScratchFileName = Text
|
||||
|
||||
type FenceType = Text
|
||||
|
||||
data Hidden = Shown | HideOutput | HideAll
|
||||
deriving (Eq, Show)
|
||||
|
||||
data UcmLine
|
||||
= UcmCommand UcmContext Text
|
||||
| UcmComment Text -- Text does not include the '--' prefix.
|
||||
|
||||
-- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>).
|
||||
data UcmContext
|
||||
= UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
|
||||
|
||||
data APIRequest
|
||||
= GetRequest Text
|
||||
| APIComment Text
|
||||
|
||||
instance Show APIRequest where
|
||||
show (GetRequest txt) = "GET " <> Text.unpack txt
|
||||
show (APIComment txt) = "-- " <> Text.unpack txt
|
||||
|
||||
pattern CMarkCodeBlock :: (Maybe CMark.PosInfo) -> Text -> Text -> CMark.Node
|
||||
pattern CMarkCodeBlock pos info body = CMark.Node pos (CMark.CODE_BLOCK info body) []
|
||||
|
||||
data Stanza
|
||||
= Ucm Hidden ExpectingError [UcmLine]
|
||||
| Unison Hidden ExpectingError (Maybe ScratchFileName) Text
|
||||
| API [APIRequest]
|
||||
| UnprocessedBlock CMark.Node
|
||||
|
||||
instance Show UcmLine where
|
||||
show = \case
|
||||
UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
|
||||
UcmComment txt -> "--" ++ Text.unpack txt
|
||||
where
|
||||
showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
|
||||
|
||||
instance Show Stanza where
|
||||
show s = (<> "\n") . Text.unpack . CMark.nodeToCommonmark [] Nothing $ stanzaToNode s
|
||||
|
||||
stanzaToNode :: Stanza -> CMark.Node
|
||||
stanzaToNode =
|
||||
\case
|
||||
Ucm _ _ cmds ->
|
||||
CMarkCodeBlock Nothing "ucm" . Text.pack $
|
||||
foldl (\x y -> x ++ show y) "" cmds
|
||||
Unison _hide _ fname txt ->
|
||||
CMarkCodeBlock Nothing "unison" . Text.pack $
|
||||
unlines
|
||||
[ case fname of
|
||||
Nothing -> Text.unpack txt
|
||||
Just fname ->
|
||||
unlines
|
||||
[ "---",
|
||||
"title: " <> Text.unpack fname,
|
||||
"---",
|
||||
Text.unpack txt
|
||||
]
|
||||
]
|
||||
API apiRequests ->
|
||||
CMarkCodeBlock Nothing "api" . Text.pack $
|
||||
( apiRequests
|
||||
& fmap show
|
||||
& unlines
|
||||
)
|
||||
UnprocessedBlock node -> node
|
||||
|
||||
parseFile :: FilePath -> IO (Either TranscriptError [Stanza])
|
||||
parseFile filePath = do
|
||||
exists <- doesFileExist filePath
|
||||
if exists
|
||||
then do
|
||||
txt <- readUtf8 filePath
|
||||
pure $ parse filePath txt
|
||||
else pure . Left . TranscriptParseError . Text.pack $ filePath <> " does not exist"
|
||||
|
||||
parse :: String -> Text -> Either TranscriptError [Stanza]
|
||||
parse srcName txt = case stanzas srcName txt of
|
||||
Right a -> Right a
|
||||
Left e -> Left . TranscriptParseError . Text.pack . P.errorBundlePretty $ e
|
||||
|
||||
type TranscriptRunner =
|
||||
( String ->
|
||||
Text ->
|
||||
(FilePath, Codebase IO Symbol Ann) ->
|
||||
IO (Either TranscriptError Text)
|
||||
)
|
||||
|
||||
withTranscriptRunner ::
|
||||
withRunner ::
|
||||
forall m r.
|
||||
(UnliftIO.MonadUnliftIO m) =>
|
||||
Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} ->
|
||||
-- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
|
||||
Bool ->
|
||||
Verbosity ->
|
||||
UCMVersion ->
|
||||
FilePath ->
|
||||
Maybe FilePath ->
|
||||
(TranscriptRunner -> m r) ->
|
||||
(Runner -> m r) ->
|
||||
m r
|
||||
withTranscriptRunner isTest verbosity ucmVersion nrtp configFile action = do
|
||||
withRunner isTest verbosity ucmVersion nrtp configFile action = do
|
||||
withRuntimes nrtp \runtime sbRuntime nRuntime -> withConfig \config -> do
|
||||
action \transcriptName transcriptSrc (codebaseDir, codebase) -> do
|
||||
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase \baseUrl -> do
|
||||
let parsed = parse transcriptName transcriptSrc
|
||||
let parsed = Transcript.stanzas transcriptName transcriptSrc
|
||||
result <- for parsed \stanzas -> do
|
||||
liftIO $ run isTest verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl)
|
||||
pure $ join @(Either TranscriptError) result
|
||||
pure . join $ first ParseError result
|
||||
where
|
||||
withRuntimes ::
|
||||
FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
|
||||
@ -227,7 +130,8 @@ withTranscriptRunner isTest verbosity ucmVersion nrtp configFile action = do
|
||||
(\(config, _cancelConfig) -> action (Just config))
|
||||
|
||||
run ::
|
||||
Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} ->
|
||||
-- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic
|
||||
Bool ->
|
||||
Verbosity ->
|
||||
FilePath ->
|
||||
[Stanza] ->
|
||||
@ -238,7 +142,7 @@ run ::
|
||||
Maybe Config ->
|
||||
UCMVersion ->
|
||||
Text ->
|
||||
IO (Either TranscriptError Text)
|
||||
IO (Either Error Text)
|
||||
run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try do
|
||||
httpManager <- HTTP.newManager HTTP.defaultManagerSettings
|
||||
(initialPP, emptyCausalHashId) <- Codebase.runTransaction codebase do
|
||||
@ -299,7 +203,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
|
||||
apiRequest :: APIRequest -> IO ()
|
||||
apiRequest req = do
|
||||
output (show req <> "\n")
|
||||
output . Text.unpack $ Transcript.formatAPIRequest req <> "\n"
|
||||
case req of
|
||||
APIComment {} -> pure ()
|
||||
GetRequest path -> do
|
||||
@ -327,13 +231,13 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
for (reverse scratchFileUpdates) \(fp, contents) -> do
|
||||
let fenceDescription = "unison:added-by-ucm " <> fp
|
||||
-- Output blocks for any scratch file updates the ucm block triggered.
|
||||
Q.undequeue inputQueue (UnprocessedBlock $ CMarkCodeBlock Nothing fenceDescription contents, Nothing)
|
||||
Q.undequeue inputQueue (Left $ CMarkCodeBlock Nothing fenceDescription contents, Nothing)
|
||||
awaitInput
|
||||
-- ucm command to run
|
||||
Just (Just ucmLine) -> do
|
||||
case ucmLine of
|
||||
p@(UcmComment {}) -> do
|
||||
liftIO (output ("\n" <> show p))
|
||||
liftIO . output . Text.unpack $ "\n" <> Transcript.formatUcmLine p
|
||||
awaitInput
|
||||
p@(UcmCommand context lineTxt) -> do
|
||||
curPath <- Cli.getCurrentProjectPath
|
||||
@ -371,7 +275,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
case words . Text.unpack $ lineTxt of
|
||||
[] -> awaitInput
|
||||
args -> do
|
||||
liftIO (output ("\n" <> show p <> "\n"))
|
||||
liftIO . output . Text.unpack $ "\n" <> Transcript.formatUcmLine p <> "\n"
|
||||
numberedArgs <- use #numberedArgs
|
||||
PP.ProjectAndBranch projId branchId <- PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack
|
||||
let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId
|
||||
@ -407,35 +311,39 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
++ show (length stanzas)
|
||||
++ "."
|
||||
IO.hFlush IO.stdout
|
||||
case s of
|
||||
UnprocessedBlock _ -> do
|
||||
liftIO (output $ show s)
|
||||
awaitInput
|
||||
Unison hide errOk filename txt -> do
|
||||
liftIO (writeIORef hidden hide)
|
||||
liftIO (outputEcho $ show s)
|
||||
liftIO (writeIORef allowErrors errOk)
|
||||
-- Open a ucm block which will contain the output from UCM
|
||||
-- after processing the UnisonFileChanged event.
|
||||
liftIO (output "``` ucm\n")
|
||||
-- Close the ucm block after processing the UnisonFileChanged event.
|
||||
atomically . Q.enqueue cmdQueue $ Nothing
|
||||
let sourceName = fromMaybe "scratch.u" filename
|
||||
liftIO $ updateVirtualFile sourceName txt
|
||||
pure $ Left (UnisonFileChanged sourceName txt)
|
||||
API apiRequests -> do
|
||||
liftIO (output "``` api\n")
|
||||
liftIO (for_ apiRequests apiRequest)
|
||||
liftIO (output "```\n\n")
|
||||
awaitInput
|
||||
Ucm hide errOk cmds -> do
|
||||
liftIO (writeIORef hidden hide)
|
||||
liftIO (writeIORef allowErrors errOk)
|
||||
liftIO (writeIORef hasErrors False)
|
||||
liftIO (output "``` ucm")
|
||||
traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
|
||||
atomically . Q.enqueue cmdQueue $ Nothing
|
||||
awaitInput
|
||||
either
|
||||
( \node -> do
|
||||
liftIO . output . Text.unpack $ Transcript.formatNode node
|
||||
awaitInput
|
||||
)
|
||||
( \block -> case block of
|
||||
Unison hide errOk filename txt -> do
|
||||
liftIO (writeIORef hidden hide)
|
||||
liftIO . outputEcho . Text.unpack $ Transcript.formatProcessedBlock block
|
||||
liftIO (writeIORef allowErrors errOk)
|
||||
-- Open a ucm block which will contain the output from UCM
|
||||
-- after processing the UnisonFileChanged event.
|
||||
liftIO (output "``` ucm\n")
|
||||
-- Close the ucm block after processing the UnisonFileChanged event.
|
||||
atomically . Q.enqueue cmdQueue $ Nothing
|
||||
let sourceName = fromMaybe "scratch.u" filename
|
||||
liftIO $ updateVirtualFile sourceName txt
|
||||
pure $ Left (UnisonFileChanged sourceName txt)
|
||||
API apiRequests -> do
|
||||
liftIO (output "``` api\n")
|
||||
liftIO (for_ apiRequests apiRequest)
|
||||
liftIO (output "```\n\n")
|
||||
awaitInput
|
||||
Ucm hide errOk cmds -> do
|
||||
liftIO (writeIORef hidden hide)
|
||||
liftIO (writeIORef allowErrors errOk)
|
||||
liftIO (writeIORef hasErrors False)
|
||||
liftIO (output "``` ucm")
|
||||
traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
|
||||
atomically . Q.enqueue cmdQueue $ Nothing
|
||||
awaitInput
|
||||
)
|
||||
s
|
||||
|
||||
loadPreviousUnisonBlock name = do
|
||||
ufs <- readIORef unisonFiles
|
||||
@ -492,7 +400,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
appendFailingStanza = do
|
||||
stanzaOpt <- readIORef mStanza
|
||||
currentOut <- readIORef out
|
||||
let stnz = maybe "" show (fmap fst stanzaOpt :: Maybe Stanza)
|
||||
let stnz = maybe "" (Text.unpack . Transcript.formatStanza . fst) stanzaOpt
|
||||
unless (stnz `isSubsequenceOf` concat currentOut) $
|
||||
modifyIORef' out (\acc -> acc <> pure stnz)
|
||||
|
||||
@ -502,13 +410,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
output "\n```\n\n"
|
||||
appendFailingStanza
|
||||
transcriptFailure out $
|
||||
Text.unlines
|
||||
[ "\128721",
|
||||
"",
|
||||
"The transcript failed due to an error in the stanza above. The error is:",
|
||||
"",
|
||||
Text.pack msg
|
||||
]
|
||||
"The transcript failed due to an error in the stanza above. The error is:\n\n" <> Text.pack msg
|
||||
|
||||
dieUnexpectedSuccess :: IO ()
|
||||
dieUnexpectedSuccess = do
|
||||
@ -517,12 +419,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
when (errOk && not hasErr) $ do
|
||||
output "\n```\n\n"
|
||||
appendFailingStanza
|
||||
transcriptFailure out $
|
||||
Text.unlines
|
||||
[ "\128721",
|
||||
"",
|
||||
"The transcript was expecting an error in the stanza above, but did not encounter one."
|
||||
]
|
||||
transcriptFailure out "The transcript was expecting an error in the stanza above, but did not encounter one."
|
||||
|
||||
authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion
|
||||
|
||||
@ -571,137 +468,10 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
|
||||
transcriptFailure :: IORef (Seq String) -> Text -> IO b
|
||||
transcriptFailure out msg = do
|
||||
texts <- readIORef out
|
||||
UnliftIO.throwIO
|
||||
. TranscriptRunFailure
|
||||
$ Text.concat (Text.pack <$> toList texts)
|
||||
<> "\n\n"
|
||||
<> msg
|
||||
UnliftIO.throwIO . RunFailure $ mconcat (Text.pack <$> toList texts) <> "\n\n\128721\n\n" <> msg <> "\n"
|
||||
|
||||
type P = P.Parsec Void Text
|
||||
|
||||
stanzas :: String -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza]
|
||||
stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromBlock blocks) . CMark.commonmarkToNode []
|
||||
where
|
||||
stanzaFromBlock block = case block of
|
||||
CMarkCodeBlock _ info body -> fromMaybe (UnprocessedBlock block) <$> P.parse (fenced info) srcName body
|
||||
_ -> pure $ UnprocessedBlock block
|
||||
|
||||
ucmLine :: P UcmLine
|
||||
ucmLine = ucmCommand <|> ucmComment
|
||||
where
|
||||
ucmCommand :: P UcmLine
|
||||
ucmCommand = do
|
||||
context <-
|
||||
P.try do
|
||||
contextString <- P.takeWhile1P Nothing (/= '>')
|
||||
context <-
|
||||
case (tryFrom @Text contextString) of
|
||||
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||
_ -> fail "expected project/branch or absolute path"
|
||||
void $ lineToken $ word ">"
|
||||
pure context
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmCommand context line
|
||||
|
||||
ucmComment :: P UcmLine
|
||||
ucmComment = do
|
||||
word "--"
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmComment line
|
||||
|
||||
apiRequest :: P APIRequest
|
||||
apiRequest = do
|
||||
apiComment <|> getRequest
|
||||
where
|
||||
getRequest = do
|
||||
word "GET"
|
||||
spaces
|
||||
path <- P.takeWhile1P Nothing (/= '\n')
|
||||
spaces
|
||||
pure (GetRequest path)
|
||||
apiComment = do
|
||||
word "--"
|
||||
comment <- P.takeWhileP Nothing (/= '\n')
|
||||
spaces
|
||||
pure (APIComment comment)
|
||||
|
||||
-- | Produce the correct parser for the code block based on the provided info string.
|
||||
fenced :: Text -> P (Maybe Stanza)
|
||||
fenced info = do
|
||||
body <- P.getInput
|
||||
P.setInput info
|
||||
fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language)
|
||||
stanza <-
|
||||
case fenceType of
|
||||
"ucm" -> do
|
||||
hide <- hidden
|
||||
err <- expectingError
|
||||
P.setInput body
|
||||
_ <- spaces
|
||||
cmds <- many ucmLine
|
||||
pure . pure $ Ucm hide err cmds
|
||||
"unison" ->
|
||||
do
|
||||
-- todo: this has to be more interesting
|
||||
-- ```unison:hide
|
||||
-- ```unison
|
||||
-- ```unison:hide:all scratch.u
|
||||
hide <- lineToken hidden
|
||||
err <- lineToken expectingError
|
||||
fileName <- optional untilSpace1
|
||||
P.setInput body
|
||||
blob <- spaces *> (Text.init <$> P.getInput)
|
||||
pure . pure $ Unison hide err fileName blob
|
||||
"api" -> do
|
||||
P.setInput body
|
||||
_ <- spaces
|
||||
apiRequests <- many apiRequest
|
||||
pure . pure $ API apiRequests
|
||||
_ -> pure Nothing
|
||||
pure stanza
|
||||
|
||||
word' :: Text -> P Text
|
||||
word' txt = P.try $ do
|
||||
chs <- P.takeP (Just $ show txt) (Text.length txt)
|
||||
guard (chs == txt)
|
||||
pure txt
|
||||
|
||||
word :: Text -> P Text
|
||||
word = word'
|
||||
|
||||
-- token :: P a -> P a
|
||||
-- token p = p <* spaces
|
||||
|
||||
lineToken :: P a -> P a
|
||||
lineToken p = p <* nonNewlineSpaces
|
||||
|
||||
nonNewlineSpaces :: P ()
|
||||
nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')
|
||||
|
||||
hidden :: P Hidden
|
||||
hidden = (\case Just x -> x; Nothing -> Shown) <$> optional go
|
||||
where
|
||||
go =
|
||||
((\_ -> HideAll) <$> (word ":hide:all"))
|
||||
<|> ((\_ -> HideOutput) <$> (word ":hide"))
|
||||
|
||||
expectingError :: P ExpectingError
|
||||
expectingError = isJust <$> optional (word ":error")
|
||||
|
||||
untilSpace1 :: P Text
|
||||
untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace)
|
||||
|
||||
language :: P Text
|
||||
language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_')
|
||||
|
||||
spaces :: P ()
|
||||
spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace
|
||||
|
||||
-- single :: Char -> P Char
|
||||
-- single t = P.satisfy (== t)
|
||||
|
||||
data TranscriptError
|
||||
= TranscriptRunFailure Text
|
||||
| TranscriptParseError Text
|
||||
data Error
|
||||
= ParseError (P.ParseErrorBundle Text Void)
|
||||
| RunFailure Text
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
@ -100,7 +100,6 @@ module Unison.CommandLine.InputPatterns
|
||||
renameTerm,
|
||||
renameType,
|
||||
reset,
|
||||
resetRoot,
|
||||
runScheme,
|
||||
saveExecuteResult,
|
||||
sfind,
|
||||
@ -1661,11 +1660,14 @@ reset =
|
||||
[ ("namespace, hash, or branch to reset to", Required, namespaceOrProjectBranchArg config),
|
||||
("namespace to be reset", Optional, namespaceOrProjectBranchArg config)
|
||||
]
|
||||
( P.wrapColumn2
|
||||
[ ("`reset #pvfd222s8n`", "reset the current namespace to the causal `#pvfd222s8n`"),
|
||||
("`reset foo`", "reset the current namespace to that of the `foo` namespace."),
|
||||
("`reset foo bar`", "reset the namespace `bar` to that of the `foo` namespace."),
|
||||
("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.")
|
||||
( P.lines
|
||||
[ P.wrapColumn2
|
||||
[ ("`reset #pvfd222s8n`", "reset the current namespace to the hash `#pvfd222s8n`"),
|
||||
("`reset foo`", "reset the current namespace to the state of the `foo` namespace."),
|
||||
("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.")
|
||||
],
|
||||
"",
|
||||
P.wrap $ "If you make a mistake using reset, consult the " <> makeExample' branchReflog <> " command and use another " <> makeExample' reset <> " command to return to a previous state."
|
||||
]
|
||||
)
|
||||
\case
|
||||
@ -1680,31 +1682,6 @@ reset =
|
||||
branchInclusion = AllBranches
|
||||
}
|
||||
|
||||
-- asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString)
|
||||
|
||||
resetRoot :: InputPattern
|
||||
resetRoot =
|
||||
InputPattern
|
||||
"reset-root"
|
||||
[]
|
||||
I.Hidden
|
||||
[("namespace or hash to reset to", Required, namespaceArg)]
|
||||
( P.lines
|
||||
[ "Deprecated because it's incompatible with projects. ⚠️ Warning, this command can cause codebase corruption.",
|
||||
P.wrapColumn2
|
||||
[ ( makeExample resetRoot [".foo"],
|
||||
"Reset the root namespace (along with its history) to that of the `.foo` namespace. Deprecated"
|
||||
),
|
||||
( makeExample resetRoot ["#9dndk3kbsk13nbpeu"],
|
||||
"Reset the root namespace (along with its history) to that of the namespace with hash `#9dndk3kbsk13nbpeu`."
|
||||
)
|
||||
]
|
||||
]
|
||||
)
|
||||
$ \case
|
||||
[src] -> Input.ResetRootI <$> handleBranchIdArg src
|
||||
args -> wrongArgsLength "exactly one argument" args
|
||||
|
||||
pull :: InputPattern
|
||||
pull =
|
||||
pullImpl "pull" [] Input.PullWithHistory ""
|
||||
@ -2293,13 +2270,13 @@ deprecatedViewRootReflog =
|
||||
branchReflog :: InputPattern
|
||||
branchReflog =
|
||||
InputPattern
|
||||
"branch.reflog"
|
||||
["reflog.branch", "reflog"]
|
||||
"reflog"
|
||||
["reflog.branch", "branch.reflog"]
|
||||
I.Visible
|
||||
[]
|
||||
( P.lines
|
||||
[ "`branch.reflog` lists all the changes that have affected the current branch.",
|
||||
"`branch.reflog /mybranch` lists all the changes that have affected /mybranch."
|
||||
[ "`reflog` lists all the changes that have affected the current branch.",
|
||||
"`reflog /mybranch` lists all the changes that have affected /mybranch."
|
||||
]
|
||||
)
|
||||
( \case
|
||||
@ -3502,7 +3479,6 @@ validInputs =
|
||||
renameType,
|
||||
moveAll,
|
||||
reset,
|
||||
resetRoot,
|
||||
runScheme,
|
||||
saveExecuteResult,
|
||||
test,
|
||||
|
@ -1292,8 +1292,8 @@ notifyUser dir = \case
|
||||
"to make an old namespace accessible again,"
|
||||
),
|
||||
(mempty, mempty),
|
||||
( IP.makeExample IP.resetRoot [prettySCH prevSCH],
|
||||
"to reset the root namespace and its history to that of the specified"
|
||||
( IP.makeExample IP.reset [prettySCH prevSCH],
|
||||
"to reset the current namespace and its history to that of the specified"
|
||||
<> "namespace."
|
||||
)
|
||||
]
|
||||
|
@ -9,7 +9,7 @@ import Unison.LSP.Types
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Handle configuration changes.
|
||||
updateConfig :: Applicative m => Config -> m ()
|
||||
updateConfig :: (Applicative m) => Config -> m ()
|
||||
updateConfig _newConfig = pure ()
|
||||
|
||||
parseConfig :: Config -> Value -> Either Text Config
|
||||
|
@ -258,7 +258,6 @@ findSmallestEnclosingNode pos term
|
||||
_ -> Nothing
|
||||
ann = getTermSpanAnn term
|
||||
|
||||
|
||||
-- | Most nodes have the property that their annotation spans all their children, but there are some exceptions.
|
||||
getTermSpanAnn :: Term Symbol Ann -> Ann
|
||||
getTermSpanAnn tm = case ABT.out tm of
|
||||
|
@ -60,6 +60,7 @@ import System.IO.CodePage (withCP65001)
|
||||
import System.IO.Error (catchIOError)
|
||||
import System.IO.Temp qualified as Temp
|
||||
import System.Path qualified as Path
|
||||
import Text.Megaparsec qualified as MP
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase (Codebase, CodebasePath)
|
||||
@ -73,7 +74,7 @@ import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime qualified as Rt
|
||||
import Unison.Codebase.SqliteCodebase qualified as SC
|
||||
import Unison.Codebase.TranscriptParser qualified as TR
|
||||
import Unison.Codebase.Transcript.Runner qualified as Transcript
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine (watchConfig)
|
||||
import Unison.CommandLine.Helpers (plural')
|
||||
@ -424,49 +425,55 @@ runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles
|
||||
currentDir <- getCurrentDirectory
|
||||
configFilePath <- getConfigFilePath mcodepath
|
||||
-- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
|
||||
and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do
|
||||
let isTest = False
|
||||
TR.withTranscriptRunner isTest Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do
|
||||
for markdownFiles $ \(MarkdownFile fileName) -> do
|
||||
transcriptSrc <- readUtf8 fileName
|
||||
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
|
||||
let outputFile = replaceExtension (currentDir </> fileName) ".output.md"
|
||||
(output, succeeded) <- case result of
|
||||
Left err -> case err of
|
||||
TR.TranscriptParseError err -> do
|
||||
PT.putPrettyLn $
|
||||
P.callout
|
||||
"❓"
|
||||
( P.lines
|
||||
[ P.indentN 2 "An error occurred while parsing the following file: " <> P.string fileName,
|
||||
"",
|
||||
P.indentN 2 $ P.text err
|
||||
]
|
||||
and
|
||||
<$> getCodebaseOrExit
|
||||
(Just (DontCreateCodebaseWhenMissing transcriptDir))
|
||||
(SC.MigrateAutomatically SC.Backup SC.Vacuum)
|
||||
\(_, codebasePath, theCodebase) -> do
|
||||
let isTest = False
|
||||
Transcript.withRunner
|
||||
isTest
|
||||
Verbosity.Verbose
|
||||
(Version.gitDescribeWithDate version)
|
||||
nativeRtp
|
||||
(Just configFilePath)
|
||||
\runTranscript -> do
|
||||
for markdownFiles $ \(MarkdownFile fileName) -> do
|
||||
transcriptSrc <- readUtf8 fileName
|
||||
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
|
||||
let outputFile = replaceExtension (currentDir </> fileName) ".output.md"
|
||||
output <-
|
||||
either
|
||||
( uncurry ($>) . first (PT.putPrettyLn . P.callout "❓" . P.lines) . \case
|
||||
Transcript.ParseError err ->
|
||||
let msg = MP.errorBundlePretty err
|
||||
in ( [ P.indentN 2 $
|
||||
"An error occurred while parsing the following file: " <> P.string fileName,
|
||||
"",
|
||||
P.indentN 2 $ P.string msg
|
||||
],
|
||||
Text.pack msg
|
||||
)
|
||||
Transcript.RunFailure msg ->
|
||||
( [ P.indentN 2 $ "An error occurred while running the following file: " <> P.string fileName,
|
||||
"",
|
||||
P.indentN 2 (P.text msg),
|
||||
P.string $
|
||||
"Run `"
|
||||
<> progName
|
||||
<> " --codebase "
|
||||
<> codebasePath
|
||||
<> "` "
|
||||
<> "to do more work with it."
|
||||
],
|
||||
msg
|
||||
)
|
||||
)
|
||||
pure (err, False)
|
||||
TR.TranscriptRunFailure err -> do
|
||||
PT.putPrettyLn $
|
||||
P.callout
|
||||
"❓"
|
||||
( P.lines
|
||||
[ P.indentN 2 "An error occurred while running the following file: " <> P.string fileName,
|
||||
"",
|
||||
P.indentN 2 $ P.text err,
|
||||
P.text $
|
||||
"Run `"
|
||||
<> Text.pack progName
|
||||
<> " --codebase "
|
||||
<> Text.pack codebasePath
|
||||
<> "` "
|
||||
<> "to do more work with it."
|
||||
]
|
||||
)
|
||||
pure (err, False)
|
||||
Right mdOut -> do
|
||||
pure (mdOut, True)
|
||||
writeUtf8 outputFile output
|
||||
putStrLn $ "💾 Wrote " <> outputFile
|
||||
pure succeeded
|
||||
pure
|
||||
result
|
||||
writeUtf8 outputFile output
|
||||
putStrLn $ "💾 Wrote " <> outputFile
|
||||
pure $ isRight result
|
||||
|
||||
runTranscripts ::
|
||||
Version ->
|
||||
|
@ -24,7 +24,7 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Init qualified as Codebase.Init
|
||||
import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError (..))
|
||||
import Unison.Codebase.SqliteCodebase qualified as SC
|
||||
import Unison.Codebase.TranscriptParser qualified as TR
|
||||
import Unison.Codebase.Transcript.Runner qualified as Transcript
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude (traceM)
|
||||
@ -66,17 +66,16 @@ runTranscript :: Codebase -> Transcript -> IO TranscriptOutput
|
||||
runTranscript (Codebase codebasePath fmt) transcript = do
|
||||
let err e = fail $ "Parse error: \n" <> show e
|
||||
cbInit = case fmt of CodebaseFormat2 -> SC.init
|
||||
let isTest = True
|
||||
TR.withTranscriptRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $ \runner -> do
|
||||
result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do
|
||||
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
|
||||
let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript
|
||||
output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
|
||||
when debugTranscriptOutput $ traceM output
|
||||
pure output
|
||||
case result of
|
||||
Left e -> fail $ P.toANSI 80 (P.shown e)
|
||||
Right x -> pure x
|
||||
isTest = True
|
||||
Transcript.withRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $
|
||||
\runner -> do
|
||||
result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do
|
||||
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
|
||||
let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript
|
||||
output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
|
||||
when debugTranscriptOutput $ traceM output
|
||||
pure output
|
||||
either (fail . P.toANSI 80 . P.shown) pure result
|
||||
where
|
||||
configFile = Nothing
|
||||
-- Note: this needs to be properly configured if these tests ever
|
||||
|
@ -22,9 +22,10 @@ import System.FilePath
|
||||
)
|
||||
import System.IO.CodePage (withCP65001)
|
||||
import System.IO.Silently (silence)
|
||||
import Text.Megaparsec qualified as MP
|
||||
import Unison.Codebase.Init (withTemporaryUcmCodebase)
|
||||
import Unison.Codebase.SqliteCodebase qualified as SC
|
||||
import Unison.Codebase.TranscriptParser (TranscriptError (..), withTranscriptRunner)
|
||||
import Unison.Codebase.Transcript.Runner as Transcript
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.Prelude
|
||||
import UnliftIO.STM qualified as STM
|
||||
@ -48,7 +49,7 @@ testBuilder ::
|
||||
testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do
|
||||
outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do
|
||||
let isTest = True
|
||||
withTranscriptRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
|
||||
Transcript.withRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
|
||||
for files \filePath -> do
|
||||
transcriptSrc <- readUtf8 filePath
|
||||
out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase)
|
||||
@ -57,12 +58,12 @@ testBuilder expectFailure recordFailure runtimePath dir prelude transcript = sco
|
||||
(filePath, Left err) -> do
|
||||
let outputFile = outputFileForTranscript filePath
|
||||
case err of
|
||||
TranscriptParseError msg -> do
|
||||
Transcript.ParseError errors -> do
|
||||
when (not expectFailure) $ do
|
||||
let errMsg = "Error parsing " <> filePath <> ": " <> Text.unpack msg
|
||||
let errMsg = "Error parsing " <> filePath <> ": " <> MP.errorBundlePretty errors
|
||||
io $ recordFailure (filePath, Text.pack errMsg)
|
||||
crash errMsg
|
||||
TranscriptRunFailure errOutput -> do
|
||||
Transcript.RunFailure errOutput -> do
|
||||
io $ writeUtf8 outputFile errOutput
|
||||
when (not expectFailure) $ do
|
||||
io $ Text.putStrLn errOutput
|
||||
|
@ -107,7 +107,9 @@ library
|
||||
Unison.Codebase.Editor.StructuredArgument
|
||||
Unison.Codebase.Editor.UCMVersion
|
||||
Unison.Codebase.Editor.UriParser
|
||||
Unison.Codebase.TranscriptParser
|
||||
Unison.Codebase.Transcript
|
||||
Unison.Codebase.Transcript.Parser
|
||||
Unison.Codebase.Transcript.Runner
|
||||
Unison.Codebase.Watch
|
||||
Unison.CommandLine
|
||||
Unison.CommandLine.BranchRelativePath
|
||||
|
@ -33,10 +33,10 @@ import Unison.Util.Alphabetical
|
||||
-- - ".." --> Name Absolute (".." :| [])
|
||||
data Name
|
||||
= Name
|
||||
-- | whether the name is positioned absolutely (to some arbitrary root namespace), or relatively
|
||||
Position
|
||||
-- ^ whether the name is positioned absolutely (to some arbitrary root namespace), or relatively
|
||||
-- | the name segments in reverse order
|
||||
(List.NonEmpty NameSegment)
|
||||
-- ^ the name segments in reverse order
|
||||
deriving stock (Eq, Generic, Show)
|
||||
|
||||
-- | Compare names (kinda) alphabetically: absolute comes before relative, but otherwise compare the name segments
|
||||
@ -49,10 +49,11 @@ instance Alphabetical Name where
|
||||
_ -> compareAlphabetical (segments n1) (segments n2)
|
||||
|
||||
instance
|
||||
TypeError
|
||||
( 'TypeError.Text
|
||||
"You cannot make a Name from a string literal because there may (some day) be more than one syntax"
|
||||
) =>
|
||||
( TypeError
|
||||
( 'TypeError.Text
|
||||
"You cannot make a Name from a string literal because there may (some day) be more than one syntax"
|
||||
)
|
||||
) =>
|
||||
IsString Name
|
||||
where
|
||||
fromString = undefined
|
||||
|
@ -56,7 +56,7 @@ type DefnsF3 f g h terms types =
|
||||
type DefnsF4 f g h i terms types =
|
||||
Defns (f (g (h (i terms)))) (f (g (h (i types))))
|
||||
|
||||
alignDefnsWith :: Semialign f => (These a b -> c) -> Defns (f a) (f b) -> f c
|
||||
alignDefnsWith :: (Semialign f) => (These a b -> c) -> Defns (f a) (f b) -> f c
|
||||
alignDefnsWith f defns =
|
||||
alignWith f defns.terms defns.types
|
||||
|
||||
|
@ -58,7 +58,7 @@ named n = typed (User n)
|
||||
|
||||
-- This bakes the fresh id into the name portion of the variable
|
||||
-- and resets the id to 0.
|
||||
bakeId :: Var v => v -> v
|
||||
bakeId :: (Var v) => v -> v
|
||||
bakeId v = named (name v)
|
||||
|
||||
rawName :: Type -> Text
|
||||
|
@ -44,7 +44,7 @@ combine :: These (DiffOp (Synhashed a)) (DiffOp (Synhashed a)) -> CombinedDiffOp
|
||||
combine =
|
||||
TwoDiffOps.make >>> combine1 >>> fmap (view #value)
|
||||
|
||||
combine1 :: Eq a => TwoDiffOps a -> CombinedDiffOp a
|
||||
combine1 :: (Eq a) => TwoDiffOps a -> CombinedDiffOp a
|
||||
combine1 = \case
|
||||
TwoDiffOps'Add x -> CombinedDiffOp'Add (xor2ior x)
|
||||
TwoDiffOps'Delete x -> CombinedDiffOp'Delete (xor2ior x)
|
||||
|
@ -47,7 +47,7 @@ data MergeDatabase = MergeDatabase
|
||||
loadV1TermComponent :: Hash -> Transaction [(V1.Term V1.Symbol V1.Ann, V1.Type V1.Symbol V1.Ann)]
|
||||
}
|
||||
|
||||
makeMergeDatabase :: MonadIO m => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase
|
||||
makeMergeDatabase :: (MonadIO m) => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase
|
||||
makeMergeDatabase codebase = liftIO do
|
||||
-- Create a bunch of cached database lookup functions
|
||||
loadCausal <- do
|
||||
|
@ -40,13 +40,13 @@ data DeclNameLookup = DeclNameLookup
|
||||
deriving stock (Generic)
|
||||
deriving (Semigroup) via (GenericSemigroupMonoid DeclNameLookup)
|
||||
|
||||
expectDeclName :: HasCallStack => DeclNameLookup -> Name -> Name
|
||||
expectDeclName :: (HasCallStack) => DeclNameLookup -> Name -> Name
|
||||
expectDeclName DeclNameLookup {constructorToDecl} x =
|
||||
case Map.lookup x constructorToDecl of
|
||||
Nothing -> error (reportBug "E246726" ("Expected constructor name key " <> show x <> " in decl name lookup"))
|
||||
Just y -> y
|
||||
|
||||
expectConstructorNames :: HasCallStack => DeclNameLookup -> Name -> [Name]
|
||||
expectConstructorNames :: (HasCallStack) => DeclNameLookup -> Name -> [Name]
|
||||
expectConstructorNames DeclNameLookup {declToConstructors} x =
|
||||
case Map.lookup x declToConstructors of
|
||||
Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup"))
|
||||
|
@ -143,7 +143,7 @@ diffNamespaceDefns =
|
||||
f old new =
|
||||
Map.mapMaybe id (alignWith g old new)
|
||||
|
||||
g :: Eq x => These x x -> Maybe (DiffOp x)
|
||||
g :: (Eq x) => These x x -> Maybe (DiffOp x)
|
||||
g = \case
|
||||
This old -> Just (DiffOp'Delete old)
|
||||
That new -> Just (DiffOp'Add new)
|
||||
@ -158,7 +158,7 @@ deepNamespaceDefinitionsToPpe :: Defns (BiMultimap Referent Name) (BiMultimap Ty
|
||||
deepNamespaceDefinitionsToPpe Defns {terms, types} =
|
||||
PrettyPrintEnv (arbitraryName terms) (arbitraryName types)
|
||||
where
|
||||
arbitraryName :: Ord ref => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
|
||||
arbitraryName :: (Ord ref) => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
|
||||
arbitraryName names ref =
|
||||
BiMultimap.lookupDom ref names
|
||||
& Set.lookupMin
|
||||
@ -168,7 +168,7 @@ deepNamespaceDefinitionsToPpe Defns {terms, types} =
|
||||
-- Syntactic hashing helpers
|
||||
|
||||
synhashDefnsWith ::
|
||||
Monad m =>
|
||||
(Monad m) =>
|
||||
(Name -> term -> m Hash) ->
|
||||
(Name -> typ -> m Hash) ->
|
||||
Defns (BiMultimap term Name) (BiMultimap typ Name) ->
|
||||
|
@ -72,11 +72,11 @@ mergeDiffs ::
|
||||
mergeDiffs alice bob =
|
||||
catMaybes (alignWith combineDiffOps alice bob)
|
||||
|
||||
combineDiffOps :: Eq a => These (DiffOp a) (DiffOp a) -> Maybe (LibdepDiffOp a)
|
||||
combineDiffOps :: (Eq a) => These (DiffOp a) (DiffOp a) -> Maybe (LibdepDiffOp a)
|
||||
combineDiffOps =
|
||||
TwoDiffOps.make >>> combineDiffOps1
|
||||
|
||||
combineDiffOps1 :: Eq a => TwoDiffOps a -> Maybe (LibdepDiffOp a)
|
||||
combineDiffOps1 :: (Eq a) => TwoDiffOps a -> Maybe (LibdepDiffOp a)
|
||||
combineDiffOps1 = \case
|
||||
TwoDiffOps'Add new -> Just (AddLibdep (EitherWay.value new))
|
||||
-- If Alice deletes a dep and Bob doesn't touch it, ignore the delete, since Bob may still be using it.
|
||||
|
@ -64,7 +64,7 @@ makeInitialIdentifyConflictsState diff =
|
||||
}
|
||||
|
||||
identifyConflicts ::
|
||||
HasCallStack =>
|
||||
(HasCallStack) =>
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference ->
|
||||
|
@ -116,11 +116,11 @@ hashConstructorNameToken declName conName =
|
||||
)
|
||||
in H.Text (Name.toText strippedConName)
|
||||
|
||||
hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash
|
||||
hashDerivedTerm :: (Var v) => PrettyPrintEnv -> Term v a -> Hash
|
||||
hashDerivedTerm ppe term =
|
||||
H.accumulate (hashDerivedTermTokens ppe term)
|
||||
|
||||
hashDerivedTermTokens :: forall a v. Var v => PrettyPrintEnv -> Term v a -> [Token]
|
||||
hashDerivedTermTokens :: forall a v. (Var v) => PrettyPrintEnv -> Term v a -> [Token]
|
||||
hashDerivedTermTokens ppe =
|
||||
(isNotBuiltinTag :) . (isTermTag :) . go []
|
||||
where
|
||||
@ -138,18 +138,18 @@ hashConstructorType = \case
|
||||
CT.Effect -> H.Tag 0
|
||||
CT.Data -> H.Tag 1
|
||||
|
||||
hashDataDeclTokens :: Var v => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
|
||||
hashDataDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> DataDeclaration v a -> [Token]
|
||||
hashDataDeclTokens ppe declName (DD.DataDeclaration modifier _ bound ctors) =
|
||||
hashModifierTokens modifier <> (ctors >>= hashConstructorTokens ppe declName bound)
|
||||
|
||||
-- separating constructor types with tag of 99, which isn't used elsewhere
|
||||
hashConstructorTokens :: Var v => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
|
||||
hashConstructorTokens :: (Var v) => PrettyPrintEnv -> Name -> [v] -> (a, v, Type v a) -> [Token]
|
||||
hashConstructorTokens ppe declName bound (_, conName, ty) =
|
||||
H.Tag 99
|
||||
: hashConstructorNameToken declName (Name.unsafeParseVar conName)
|
||||
: hashTypeTokens ppe bound ty
|
||||
|
||||
hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token]
|
||||
hashDeclTokens :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> [Token]
|
||||
hashDeclTokens ppe name decl =
|
||||
hashConstructorType (DD.constructorType decl) : hashDataDeclTokens ppe name (DD.asDataDecl decl)
|
||||
|
||||
@ -157,7 +157,7 @@ hashDeclTokens ppe name decl =
|
||||
-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same,
|
||||
-- the constructors appear in the same order and have the same names, and the constructors' types have the same
|
||||
-- syntactic hashes.
|
||||
synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash
|
||||
synhashDerivedDecl :: (Var v) => PrettyPrintEnv -> Name -> Decl v a -> Hash
|
||||
synhashDerivedDecl ppe name decl =
|
||||
H.accumulate $ isNotBuiltinTag : isDeclTag : hashDeclTokens ppe name decl
|
||||
|
||||
@ -170,7 +170,7 @@ hashKindTokens k = case k of
|
||||
K.Star -> [H.Tag 0]
|
||||
K.Arrow k1 k2 -> H.Tag 1 : (hashKindTokens k1 <> hashKindTokens k2)
|
||||
|
||||
hashLengthToken :: Foldable t => t a -> Token
|
||||
hashLengthToken :: (Foldable t) => t a -> Token
|
||||
hashLengthToken =
|
||||
H.Nat . fromIntegral @Int @Word64 . length
|
||||
|
||||
@ -224,7 +224,7 @@ synhashTerm loadTerm ppe = \case
|
||||
ReferenceBuiltin builtin -> pure (hashBuiltinTerm builtin)
|
||||
ReferenceDerived ref -> hashDerivedTerm ppe <$> loadTerm ref
|
||||
|
||||
hashTermFTokens :: Var v => PrettyPrintEnv -> Term.F v a a () -> [Token]
|
||||
hashTermFTokens :: (Var v) => PrettyPrintEnv -> Term.F v a a () -> [Token]
|
||||
hashTermFTokens ppe = \case
|
||||
Term.Int n -> [H.Tag 0, H.Int n]
|
||||
Term.Nat n -> [H.Tag 1, H.Nat n]
|
||||
@ -255,11 +255,11 @@ hashTermFTokens ppe = \case
|
||||
-- | Syntactically hash a type, using reference names rather than hashes.
|
||||
-- Two types will have the same syntactic hash if they would
|
||||
-- print the the same way under the given pretty-print env.
|
||||
synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash
|
||||
synhashType :: (Var v) => PrettyPrintEnv -> Type v a -> Hash
|
||||
synhashType ppe ty =
|
||||
H.accumulate $ hashTypeTokens ppe [] ty
|
||||
|
||||
hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> [v] -> Type v a -> [Token]
|
||||
hashTypeTokens :: forall v a. (Var v) => PrettyPrintEnv -> [v] -> Type v a -> [Token]
|
||||
hashTypeTokens ppe = go
|
||||
where
|
||||
go :: [v] -> Type v a -> [Token]
|
||||
@ -286,7 +286,7 @@ hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token
|
||||
hashTypeReferenceToken ppe =
|
||||
hashHQNameToken . PPE.typeNameOrHashOnlyFq ppe
|
||||
|
||||
hashVarToken :: Var v => [v] -> v -> Token
|
||||
hashVarToken :: (Var v) => [v] -> v -> Token
|
||||
hashVarToken bound v =
|
||||
case List.elemIndex v bound of
|
||||
Nothing -> error (reportBug "E633940" ("var " ++ show v ++ " not bound in " ++ show bound))
|
||||
|
@ -80,7 +80,7 @@ twoWay f TwoWay {alice, bob} =
|
||||
f alice bob
|
||||
|
||||
-- | Unzip a @Map k (TwoWay v)@ into a @TwoWay (Map k v)@.
|
||||
unzipMap :: Ord k => Map k (TwoWay v) -> TwoWay (Map k v)
|
||||
unzipMap :: (Ord k) => Map k (TwoWay v) -> TwoWay (Map k v)
|
||||
unzipMap =
|
||||
fromPair . unzipWith (\TwoWay {alice, bob} -> (alice, bob))
|
||||
|
||||
|
@ -213,10 +213,10 @@ data BackendError
|
||||
= NoSuchNamespace Path.Absolute
|
||||
| -- Failed to parse path
|
||||
BadNamespace
|
||||
-- | error message
|
||||
String
|
||||
-- ^ error message
|
||||
-- | namespace
|
||||
String
|
||||
-- ^ namespace
|
||||
| CouldntExpandBranchHash ShortCausalHash
|
||||
| AmbiguousBranchHash ShortCausalHash (Set ShortCausalHash)
|
||||
| AmbiguousHashForDefinition ShortHash
|
||||
@ -462,11 +462,11 @@ getTermTag codebase r sig = do
|
||||
V2Referent.Con ref _ -> Just <$> Codebase.runTransaction codebase (Codebase.getDeclType codebase ref)
|
||||
pure $
|
||||
if
|
||||
| isDoc -> Doc
|
||||
| isTest -> Test
|
||||
| Just CT.Effect <- constructorType -> Constructor Ability
|
||||
| Just CT.Data <- constructorType -> Constructor Data
|
||||
| otherwise -> Plain
|
||||
| isDoc -> Doc
|
||||
| isTest -> Test
|
||||
| Just CT.Effect <- constructorType -> Constructor Ability
|
||||
| Just CT.Data <- constructorType -> Constructor Data
|
||||
| otherwise -> Plain
|
||||
|
||||
getTypeTag ::
|
||||
(Var v) =>
|
||||
|
@ -16,7 +16,7 @@ import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..))
|
||||
import Unison.Util.AnnotatedText (AnnotatedText (..))
|
||||
import Unison.Util.AnnotatedText qualified as AT
|
||||
|
||||
diffDisplayObjects :: HasCallStack => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
|
||||
diffDisplayObjects :: (HasCallStack) => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff
|
||||
diffDisplayObjects from to = case (from, to) of
|
||||
(BuiltinObject fromST, BuiltinObject toST) -> DisplayObjectDiff (BuiltinObject (diffSyntaxText fromST toST))
|
||||
(MissingObject fromSH, MissingObject toSH)
|
||||
|
@ -11,5 +11,5 @@ import Unison.Server.Local.Endpoints.Current (Current, CurrentEndpoint, serveCur
|
||||
type UCMAPI =
|
||||
CurrentEndpoint
|
||||
|
||||
ucmServer :: MonadIO m => Codebase m v a -> Backend m Current
|
||||
ucmServer :: (MonadIO m) => Codebase m v a -> Backend m Current
|
||||
ucmServer codebase = serveCurrent codebase
|
||||
|
@ -48,12 +48,6 @@ module Unison.Sync.Types
|
||||
UploadEntitiesResponse (..),
|
||||
UploadEntitiesError (..),
|
||||
|
||||
-- ** Update path
|
||||
UpdatePathRequest (..),
|
||||
UpdatePathResponse (..),
|
||||
UpdatePathError (..),
|
||||
HashMismatch (..),
|
||||
|
||||
-- * Common/shared error types
|
||||
HashMismatchForEntity (..),
|
||||
InvalidParentage (..),
|
||||
@ -756,89 +750,6 @@ instance FromJSON InvalidParentage where
|
||||
parseJSON =
|
||||
Aeson.withObject "InvalidParentage" \o -> InvalidParentage <$> o .: "parent" <*> o .: "child"
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Update path
|
||||
|
||||
data UpdatePathRequest = UpdatePathRequest
|
||||
{ path :: Path,
|
||||
expectedHash :: Maybe Hash32, -- Nothing requires empty history at destination
|
||||
newHash :: Hash32
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance ToJSON UpdatePathRequest where
|
||||
toJSON (UpdatePathRequest path expectedHash newHash) =
|
||||
object
|
||||
[ "path" .= path,
|
||||
"expected_hash" .= expectedHash,
|
||||
"new_hash" .= newHash
|
||||
]
|
||||
|
||||
instance FromJSON UpdatePathRequest where
|
||||
parseJSON = Aeson.withObject "UpdatePathRequest" \obj -> do
|
||||
path <- obj .: "path"
|
||||
expectedHash <- obj .: "expected_hash"
|
||||
newHash <- obj .: "new_hash"
|
||||
pure UpdatePathRequest {..}
|
||||
|
||||
data UpdatePathResponse
|
||||
= UpdatePathSuccess
|
||||
| UpdatePathFailure UpdatePathError
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
data UpdatePathError
|
||||
= UpdatePathError'HashMismatch HashMismatch
|
||||
| UpdatePathError'InvalidRepoInfo Text RepoInfo -- err msg, repo info
|
||||
| UpdatePathError'MissingDependencies (NeedDependencies Hash32)
|
||||
| UpdatePathError'NoWritePermission Path
|
||||
| UpdatePathError'UserNotFound
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance ToJSON UpdatePathResponse where
|
||||
toJSON = \case
|
||||
UpdatePathSuccess -> jsonUnion "success" (Object mempty)
|
||||
UpdatePathFailure (UpdatePathError'HashMismatch hm) -> jsonUnion "hash_mismatch" hm
|
||||
UpdatePathFailure (UpdatePathError'MissingDependencies md) -> jsonUnion "missing_dependencies" md
|
||||
UpdatePathFailure (UpdatePathError'NoWritePermission path) -> jsonUnion "no_write_permission" path
|
||||
UpdatePathFailure (UpdatePathError'InvalidRepoInfo errMsg repoInfo) -> jsonUnion "invalid_repo_info" (errMsg, repoInfo)
|
||||
UpdatePathFailure UpdatePathError'UserNotFound -> jsonUnion "user_not_found" (Object mempty)
|
||||
|
||||
instance FromJSON UpdatePathResponse where
|
||||
parseJSON v =
|
||||
v & Aeson.withObject "UpdatePathResponse" \obj ->
|
||||
obj .: "type" >>= Aeson.withText "type" \case
|
||||
"success" -> pure UpdatePathSuccess
|
||||
"hash_mismatch" -> UpdatePathFailure . UpdatePathError'HashMismatch <$> obj .: "payload"
|
||||
"missing_dependencies" -> UpdatePathFailure . UpdatePathError'MissingDependencies <$> obj .: "payload"
|
||||
"no_write_permission" -> UpdatePathFailure . UpdatePathError'NoWritePermission <$> obj .: "payload"
|
||||
"invalid_repo_info" -> do
|
||||
(errMsg, repoInfo) <- obj .: "payload"
|
||||
pure (UpdatePathFailure (UpdatePathError'InvalidRepoInfo errMsg repoInfo))
|
||||
"user_not_found" -> pure (UpdatePathFailure UpdatePathError'UserNotFound)
|
||||
t -> failText $ "Unexpected UpdatePathResponse type: " <> t
|
||||
|
||||
data HashMismatch = HashMismatch
|
||||
{ path :: Path,
|
||||
expectedHash :: Maybe Hash32,
|
||||
actualHash :: Maybe Hash32
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance ToJSON HashMismatch where
|
||||
toJSON (HashMismatch path expectedHash actualHash) =
|
||||
object
|
||||
[ "path" .= path,
|
||||
"expected_hash" .= expectedHash,
|
||||
"actual_hash" .= actualHash
|
||||
]
|
||||
|
||||
instance FromJSON HashMismatch where
|
||||
parseJSON = Aeson.withObject "HashMismatch" \obj -> do
|
||||
path <- obj .: "path"
|
||||
expectedHash <- obj .: "expected_hash"
|
||||
actualHash <- obj .: "actual_hash"
|
||||
pure HashMismatch {..}
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Common/shared error types
|
||||
|
||||
|
@ -34,9 +34,9 @@ foo = do
|
||||
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 : '{Exception} ()
|
||||
|
||||
```
|
||||
@ -58,10 +58,10 @@ an exception.
|
||||
runtime-tests/selected> run.native testBug
|
||||
|
||||
💔💥
|
||||
|
||||
|
||||
I've encountered a call to builtin.bug with the following
|
||||
value:
|
||||
|
||||
|
||||
"testing"
|
||||
|
||||
```
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user