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

⅄ trunk → update-defn-order

Browse Source
This commit is contained in:
Mitchell Rosen 2024-07-24 02:40:13 -04:00
commit e64ffb6f2c
113 changed files with 796 additions and 898 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/ci.yaml vendored
View File

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

@ -0,0 +1,4 @@
infixl 8 ^?
infixr 4 %%~, %~
infixl 3 <|>
infixl 1 &, <&>

2
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Branch/Hashing.hs
View File

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

4
codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs
View File

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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs
View File

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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs
View File

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

24
codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs
View File

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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs
View File

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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs
View File

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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -289,7 +289,7 @@ module U.Codebase.Sqlite.Queries
-- * Types
NamespaceText,
TextPathSegments,
JsonParseFailure(..),
JsonParseFailure (..),
)
where

6
codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs
View File

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

4
codebase2/codebase/U/Codebase/Causal.hs
View File

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

6
codebase2/codebase/U/Codebase/Decl.hs
View File

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

4
codebase2/codebase/U/Codebase/Term.hs
View File

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

13
codebase2/core/Unison/NameSegment/Internal.hs
View File

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

4
codebase2/core/Unison/Util/Alphabetical.hs
View File

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

2
codebase2/util-serialization/U/Util/Serialization.hs
View File

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

55
development.markdown
View File

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

2
lib/unison-prelude/src/Unison/Prelude.hs
View File

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

16
lib/unison-prelude/src/Unison/Util/Map.hs
View File

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

2
lib/unison-prelude/src/Unison/Util/Tuple.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Tuple utils.
module Unison.Util.Tuple

4
lib/unison-sqlite/src/Unison/Sqlite/Connection.hs
View File

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

2
lib/unison-sqlite/src/Unison/Sqlite/Exception.hs
View File

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

2
lib/unison-sqlite/src/Unison/Sqlite/Sql.hs
View File

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

18
lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs
View File

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

6
lib/unison-util-bytes/test/Main.hs
View File

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

22
lib/unison-util-relation/src/Unison/Util/BiMultimap.hs
View File

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

31
nix/haskell-nix-flake.nix
View File

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

2
parser-typechecker/src/U/Codebase/Branch/Diff.hs
View File

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

4
parser-typechecker/src/Unison/Builtin/Decls.hs
View File

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

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

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

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

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

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

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

2
parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs
View File

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

2
parser-typechecker/src/Unison/KindInference.hs
View File

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

16
parser-typechecker/src/Unison/KindInference/Constraint/Pretty.hs
View File

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

40
parser-typechecker/src/Unison/KindInference/Error.hs
View File

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

2
parser-typechecker/src/Unison/KindInference/Error/Pretty.hs
View File

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

4
parser-typechecker/src/Unison/KindInference/Generate.hs
View File

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

10
parser-typechecker/src/Unison/KindInference/Generate/Monad.hs
View File

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

24
parser-typechecker/src/Unison/KindInference/Solve.hs
View File

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

6
parser-typechecker/src/Unison/KindInference/Solve/Monad.hs
View File

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

2
parser-typechecker/src/Unison/Parsers.hs
View File

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

12
parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs
View File

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

12
parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs
View File

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

8
parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs
View File

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

28
parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs
View File

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

2
parser-typechecker/src/Unison/Result.hs
View File

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

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

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

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

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

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

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

2
parser-typechecker/src/Unison/Runtime/Array.hs
View File

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

2
parser-typechecker/src/Unison/Runtime/Exception.hs
View File

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

6
parser-typechecker/src/Unison/Runtime/Interface.hs
View File

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

13
parser-typechecker/src/Unison/Runtime/Serialize.hs
View File

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

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

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

9
parser-typechecker/src/Unison/Syntax/TermParser.hs
View File

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

6
parser-typechecker/src/Unison/Syntax/TermPrinter.hs
View File

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

2
parser-typechecker/src/Unison/Syntax/TypeParser.hs
View File

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

2
parser-typechecker/src/Unison/Typechecker.hs
View File

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

6
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

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

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

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

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

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

4
parser-typechecker/src/Unison/Util/Text.hs
View File

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

6
parser-typechecker/tests/Unison/Test/Util/Text.hs
View File

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

7
scheme-libs/racket/unison/crypto.rkt
View File

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

2
unison-cli/src/Unison/Cli/DownloadUtils.hs
View File

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

12
unison-cli/src/Unison/Cli/ServantClientUtils.hs
View File

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

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

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

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

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

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

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

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

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

5
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

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

362
unison-cli/src/Unison/Codebase/TranscriptParser.hs → unison-cli/src/Unison/Codebase/Transcript/Runner.hs
View File

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

48
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

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

4
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -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."
)
]

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

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

1
unison-cli/src/Unison/LSP/Queries.hs
View File

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

93
unison-cli/src/Unison/Main.hs
View File

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

23
unison-cli/tests/Unison/Test/Ucm.hs
View File

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

11
unison-cli/transcripts/Transcripts.hs
View File

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

4
unison-cli/unison-cli.cabal
View File

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

13
unison-core/src/Unison/Name/Internal.hs
View File

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

2
unison-core/src/Unison/Util/Defns.hs
View File

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

2
unison-core/src/Unison/Var.hs
View File

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

2
unison-merge/src/Unison/Merge/CombineDiffs.hs
View File

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

2
unison-merge/src/Unison/Merge/Database.hs
View File

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

4
unison-merge/src/Unison/Merge/DeclNameLookup.hs
View File

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

6
unison-merge/src/Unison/Merge/Diff.hs
View File

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

4
unison-merge/src/Unison/Merge/Libdeps.hs
View File

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

2
unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs
View File

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

22
unison-merge/src/Unison/Merge/Synhash.hs
View File

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

2
unison-merge/src/Unison/Merge/TwoWay.hs
View File

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

14
unison-share-api/src/Unison/Server/Backend.hs
View File

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

2
unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs
View File

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

2
unison-share-api/src/Unison/Server/Local/Endpoints/UCM.hs
View File

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

89
unison-share-api/src/Unison/Sync/Types.hs
View File

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

8
unison-src/builtin-tests/jit-tests.output.md
View File

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