unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-22 07:48:10 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/trunk' into wip/codebase2

Browse Source 
# Conflicts:
#	parser-typechecker/src/Unison/Codebase.hs
#	parser-typechecker/src/Unison/Codebase/Branch.hs
#	parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
#	parser-typechecker/tests/Unison/Test/ANF.hs
#	parser-typechecker/unison-parser-typechecker.cabal
#	parser-typechecker/unison/Main.hs
#	stack.yaml
This commit is contained in:
Arya Irani 2021-03-10 13:57:04 -05:00
commit d1ddcfef45
126 changed files with 4361 additions and 3035 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CONTRIBUTORS.markdown
View File

@ -48,3 +48,5 @@ The format for this list: name, GitHub handle, and then optional blurb about wha
* Jared Forsyth (@jaredly) - Documentation generation
* Hakim Cassimally (@osfameron) - vim support
* Will Badart (@wbadart)
* Sam Roberts (@samgqroberts)
* Nigel Farrelly (@nini-faroux)

2
codebase1/codebase/Unison/Codebase/V1/Serialization/V1.hs
View File

@ -270,7 +270,7 @@ getTerm' getVar getA = getABT getVar getA go
8 -> Term.Handle <$> getChild <*> getChild
9 -> Term.App <$> getChild <*> getChild
10 -> Term.Ann <$> getChild <*> getType' getVar getA
11 -> Term.Sequence . Sequence.fromList <$> getList getChild
11 -> Term.List . Sequence.fromList <$> getList getChild
12 -> Term.If <$> getChild <*> getChild <*> getChild
13 -> Term.And <$> getChild <*> getChild
14 -> Term.Or <$> getChild <*> getChild

4
codebase1/codebase/Unison/Codebase/V1/Term.hs
View File

@ -56,7 +56,7 @@ data F typeVar typeAnn a
| Handle a a
| App a a
| Ann a (Type typeVar typeAnn)
| Sequence (Seq a)
| List (Seq a)
| If a a a
| And a a
| Or a a
@ -137,7 +137,7 @@ generalizedDependencies termRef typeRef literalType dataConstructor dataType eff
f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t
f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t
f t@(Text _) = Writer.tell [literalType Type.textRef] $> t
f t@(Sequence _) = Writer.tell [literalType Type.vectorRef] $> t
f t@(List _) = Writer.tell [literalType Type.listRef] $> t
f t@(Constructor r cid) =
Writer.tell [dataType r, dataConstructor r cid] $> t
f t@(Request r cid) =

4
codebase1/codebase/Unison/Codebase/V1/Term/Pattern.hs
View File

@ -82,8 +82,8 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e
EffectPure _ -> [effectType Type.effectRef]
EffectBind r cid _ _ ->
[effectType Type.effectRef, effectType r, effectConstructor r cid]
SequenceLiteral _ -> [literalType Type.vectorRef]
SequenceOp {} -> [literalType Type.vectorRef]
SequenceLiteral _ -> [literalType Type.listRef]
SequenceOp {} -> [literalType Type.listRef]
Boolean _ -> [literalType Type.booleanRef]
Int _ -> [literalType Type.intRef]
Nat _ -> [literalType Type.natRef]

4
codebase1/codebase/Unison/Codebase/V1/Type.hs
View File

@ -41,14 +41,14 @@ dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
f t@(Ref r) = Writer.tell [r] $> t
f t = pure t
intRef, natRef, floatRef, booleanRef, textRef, charRef, vectorRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
intRef = Reference.Builtin "Int"
natRef = Reference.Builtin "Nat"
floatRef = Reference.Builtin "Float"
booleanRef = Reference.Builtin "Boolean"
textRef = Reference.Builtin "Text"
charRef = Reference.Builtin "Char"
vectorRef = Reference.Builtin "Sequence"
listRef = Reference.Builtin "Sequence"
bytesRef = Reference.Builtin "Bytes"
effectRef = Reference.Builtin "Effect"
termLinkRef = Reference.Builtin "Link.Term"

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

@ -14,8 +14,8 @@ module U.Codebase.Sqlite.Operations where
import Control.Lens (Lens')
import qualified Control.Lens as Lens
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad (MonadPlus (mzero), join, when, (<=<))
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad.State (MonadState, StateT, evalStateT)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
@ -46,6 +46,7 @@ import Data.Tuple.Extra (uncurry3)
import qualified Data.Vector as Vector
import Data.Word (Word64)
import Debug.Trace
import GHC.Stack (HasCallStack)
import qualified U.Codebase.Branch as C.Branch
import qualified U.Codebase.Causal as C
import U.Codebase.Decl (ConstructorId)
@ -121,7 +122,6 @@ import qualified U.Util.Type as TypeUtil
-- * Error handling
type Err m = MonadError Error m
debug :: Bool
debug = False
@ -498,7 +498,7 @@ c2xTerm saveText saveDefn tm tp =
C.Term.Handle a a2 -> pure $ C.Term.Handle a a2
C.Term.App a a2 -> pure $ C.Term.App a a2
C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ
C.Term.Sequence as -> pure $ C.Term.Sequence as
C.Term.List as -> pure $ C.Term.List as
C.Term.If c t f -> pure $ C.Term.If c t f
C.Term.And a a2 -> pure $ C.Term.And a a2
C.Term.Or a a2 -> pure $ C.Term.Or a a2

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

@ -202,7 +202,7 @@ putTerm t = putABT putSymbol putUnit putF t
putWord8 9 *> putChild f *> putChild arg
Term.Ann e t ->
putWord8 10 *> putChild e *> putTType t
Term.Sequence vs ->
Term.List vs ->
putWord8 11 *> putFoldable putChild vs
Term.If cond t f ->
putWord8 12 *> putChild cond *> putChild t *> putChild f
@ -284,7 +284,7 @@ getTerm = getABT getSymbol getUnit getF
8 -> Term.Handle <$> getChild <*> getChild
9 -> Term.App <$> getChild <*> getChild
10 -> Term.Ann <$> getChild <*> getType getReference
11 -> Term.Sequence <$> getSequence getChild
11 -> Term.List <$> getSequence getChild
12 -> Term.If <$> getChild <*> getChild <*> getChild
13 -> Term.And <$> getChild <*> getChild
14 -> Term.Or <$> getChild <*> getChild

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

@ -106,7 +106,7 @@ trySync ::
Generation ->
Entity ->
m (TrySyncResult Entity)
trySync tCache hCache oCache gc = \case
trySync tCache hCache oCache _gc = \case
-- for causals, we need to get the value_hash_id of the thingo
-- - maybe enqueue their parents
-- - enqueue the self_ and value_ hashes

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

@ -75,7 +75,7 @@ data F' text termRef typeRef termLink typeLink vt a
| Handle a a
| App a a
| Ann a (TypeR typeRef vt)
| Sequence (Seq a)
| List (Seq a)
| If a a a
| And a a
| Or a a
@ -169,7 +169,7 @@ extraMap ftext ftermRef ftypeRef ftermLink ftypeLink fvt = go'
Handle e h -> Handle e h
App f a -> App f a
Ann a typ -> Ann a (Type.rmap ftypeRef $ ABT.vmap fvt typ)
Sequence s -> Sequence s
List s -> List s
If c t f -> If c t f
And p q -> And p q
Or p q -> Or p q
@ -292,7 +292,7 @@ instance (Eq v, Show v) => H.Hashable1 (F v) where
error "handled above, but GHC can't figure this out"
App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)]
Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)]
Sequence as ->
List as ->
tag 5 :
varint (fromIntegral (length as)) :
map

106
parser-typechecker/src/Unison/Builtin.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
@ -170,8 +169,6 @@ builtinTypesSrc =
, B' "Value" CT.Data
, B' "Any" CT.Data
, B' "crypto.HashAlgorithm" CT.Data
, B' "IOFailure" CT.Data, Rename' "IOFailure" "io2.IOFailure"
, B' "TlsFailure" CT.Data, Rename' "TlsFailure" "io2.TlsFailure"
, B' "Tls" CT.Data, Rename' "Tls" "io2.Tls"
, B' "Tls.ClientConfig" CT.Data, Rename' "Tls.ClientConfig" "io2.Tls.ClientConfig"
, B' "Tls.ServerConfig" CT.Data, Rename' "Tls.ServerConfig" "io2.Tls.ServerConfig"
@ -395,7 +392,7 @@ builtinsSrc =
, B "Text.toCharList" $ text --> list char
, B "Text.fromCharList" $ list char --> text
, B "Text.toUtf8" $ text --> bytes
, B "Text.fromUtf8.v3" $ bytes --> eithert failure text
, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text
, B "Char.toNat" $ char --> nat
, B "Char.fromNat" $ nat --> char
@ -509,55 +506,54 @@ hashBuiltins =
ioBuiltins :: Var v => [(Text, Type v)]
ioBuiltins =
[ ("IO.openFile.v3", text --> fmode --> iof handle)
, ("IO.closeFile.v3", handle --> iof unit)
, ("IO.isFileEOF.v3", handle --> iof boolean)
, ("IO.isFileOpen.v3", handle --> iof boolean)
, ("IO.isSeekable.v3", handle --> iof boolean)
, ("IO.seekHandle.v3", handle --> smode --> int --> iof unit)
, ("IO.handlePosition.v3", handle --> iof nat)
, ("IO.getBuffering.v3", handle --> iof bmode)
, ("IO.setBuffering.v3", handle --> bmode --> iof unit)
, ("IO.getBytes.v3", handle --> nat --> iof bytes)
, ("IO.putBytes.v3", handle --> bytes --> iof unit)
, ("IO.systemTime.v3", unit --> iof nat)
, ("IO.getTempDirectory.v3", unit --> iof text)
, ("IO.createTempDirectory", text --> iof text)
, ("IO.getCurrentDirectory.v3", unit --> iof text)
, ("IO.setCurrentDirectory.v3", text --> iof unit)
, ("IO.fileExists.v3", text --> iof boolean)
, ("IO.isDirectory.v3", text --> iof boolean)
, ("IO.createDirectory.v3", text --> iof unit)
, ("IO.removeDirectory.v3", text --> iof unit)
, ("IO.renameDirectory.v3", text --> text --> iof unit)
, ("IO.removeFile.v3", text --> iof unit)
, ("IO.renameFile.v3", text --> text --> iof unit)
, ("IO.getFileTimestamp.v3", text --> iof nat)
, ("IO.getFileSize.v3", text --> iof nat)
, ("IO.serverSocket.v3", optionalt text --> text --> iof socket)
, ("IO.listen.v3", socket --> iof unit)
, ("IO.clientSocket.v3", text --> text --> iof socket)
, ("IO.closeSocket.v3", socket --> iof unit)
, ("IO.socketPort", socket --> iof nat)
, ("IO.socketAccept.v3", socket --> iof socket)
, ("IO.socketSend.v3", socket --> bytes --> iof unit)
, ("IO.socketReceive.v3", socket --> nat --> iof bytes)
, ("IO.forkComp.v2"
, forall1 "a" $ \a -> (unit --> io a) --> io threadId)
[ ("IO.openFile.impl.v3", text --> fmode --> iof handle)
, ("IO.closeFile.impl.v3", handle --> iof unit)
, ("IO.isFileEOF.impl.v3", handle --> iof boolean)
, ("IO.isFileOpen.impl.v3", handle --> iof boolean)
, ("IO.isSeekable.impl.v3", handle --> iof boolean)
, ("IO.seekHandle.impl.v3", handle --> smode --> int --> iof unit)
, ("IO.handlePosition.impl.v3", handle --> iof nat)
, ("IO.getBuffering.impl.v3", handle --> iof bmode)
, ("IO.setBuffering.impl.v3", handle --> bmode --> iof unit)
, ("IO.getBytes.impl.v3", handle --> nat --> iof bytes)
, ("IO.putBytes.impl.v3", handle --> bytes --> iof unit)
, ("IO.systemTime.impl.v3", unit --> iof nat)
, ("IO.getTempDirectory.impl.v3", unit --> iof text)
, ("IO.createTempDirectory.impl.v3", text --> iof text)
, ("IO.getCurrentDirectory.impl.v3", unit --> iof text)
, ("IO.setCurrentDirectory.impl.v3", text --> iof unit)
, ("IO.fileExists.impl.v3", text --> iof boolean)
, ("IO.isDirectory.impl.v3", text --> iof boolean)
, ("IO.createDirectory.impl.v3", text --> iof unit)
, ("IO.removeDirectory.impl.v3", text --> iof unit)
, ("IO.renameDirectory.impl.v3", text --> text --> iof unit)
, ("IO.removeFile.impl.v3", text --> iof unit)
, ("IO.renameFile.impl.v3", text --> text --> iof unit)
, ("IO.getFileTimestamp.impl.v3", text --> iof nat)
, ("IO.getFileSize.impl.v3", text --> iof nat)
, ("IO.serverSocket.impl.v3", optionalt text --> text --> iof socket)
, ("IO.listen.impl.v3", socket --> iof unit)
, ("IO.clientSocket.impl.v3", text --> text --> iof socket)
, ("IO.closeSocket.impl.v3", socket --> iof unit)
, ("IO.socketPort.impl.v3", socket --> iof nat)
, ("IO.socketAccept.impl.v3", socket --> iof socket)
, ("IO.socketSend.impl.v3", socket --> bytes --> iof unit)
, ("IO.socketReceive.impl.v3", socket --> nat --> iof bytes)
, ("IO.forkComp.v2", forall1 "a" $ \a -> (unit --> io a) --> io threadId)
, ("IO.stdHandle", stdhandle --> handle)
, ("IO.delay.v3", nat --> iof unit)
, ("IO.kill.v3", threadId --> iof unit)
, ("Tls.newClient", tlsClientConfig --> socket --> iof tls)
, ("Tls.newServer", tlsServerConfig --> socket --> iof tls)
, ("Tls.handshake", tls --> iof unit)
, ("Tls.send", tls --> bytes --> iof unit)
, ("Tls.decodeCert", bytes --> eithert failure tlsSignedCert)
, ("IO.delay.impl.v3", nat --> iof unit)
, ("IO.kill.impl.v3", threadId --> iof unit)
, ("Tls.newClient.impl.v3", tlsClientConfig --> socket --> iof tls)
, ("Tls.newServer.impl.v3", tlsServerConfig --> socket --> iof tls)
, ("Tls.handshake.impl.v3", tls --> iof unit)
, ("Tls.send.impl.v3", tls --> bytes --> iof unit)
, ("Tls.decodeCert.impl.v3", bytes --> eithert failure tlsSignedCert)
, ("Tls.encodeCert", tlsSignedCert --> bytes)
, ("Tls.decodePrivateKey", bytes --> list tlsPrivateKey)
, ("Tls.encodePrivateKey", tlsPrivateKey --> bytes)
, ("Tls.receive", tls --> iof bytes)
, ("Tls.terminate", tls --> iof unit)
, ("Tls.receive.impl.v3", tls --> iof bytes)
, ("Tls.terminate.impl.v3", tls --> iof unit)
, ("Tls.ClientConfig.default", text --> bytes --> tlsClientConfig)
, ("Tls.ServerConfig.default", list tlsSignedCert --> tlsPrivateKey --> tlsServerConfig)
, ("TLS.ClientConfig.ciphers.set", list tlsCipher --> tlsClientConfig --> tlsClientConfig)
@ -573,14 +569,14 @@ mvarBuiltins :: forall v. Var v => [(Text, Type v)]
mvarBuiltins =
[ ("MVar.new", forall1 "a" $ \a -> a --> io (mvar a))
, ("MVar.newEmpty.v2", forall1 "a" $ \a -> unit --> io (mvar a))
, ("MVar.take.v3", forall1 "a" $ \a -> mvar a --> iof a)
, ("MVar.take.impl.v3", forall1 "a" $ \a -> mvar a --> iof a)
, ("MVar.tryTake", forall1 "a" $ \a -> mvar a --> io (optionalt a))
, ("MVar.put.v3", forall1 "a" $ \a -> mvar a --> a --> iof unit)
, ("MVar.tryPut", forall1 "a" $ \a -> mvar a --> a --> io boolean)
, ("MVar.swap.v3", forall1 "a" $ \a -> mvar a --> a --> iof a)
, ("MVar.put.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof unit)
, ("MVar.tryPut.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof boolean)
, ("MVar.swap.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof a)
, ("MVar.isEmpty", forall1 "a" $ \a -> mvar a --> io boolean)
, ("MVar.read.v3", forall1 "a" $ \a -> mvar a --> iof a)
, ("MVar.tryRead", forall1 "a" $ \a -> mvar a --> io (optionalt a))
, ("MVar.read.impl.v3", forall1 "a" $ \a -> mvar a --> iof a)
, ("MVar.tryRead.impl.v3", forall1 "a" $ \a -> mvar a --> iof (optionalt a))
]
where
mvar :: Type v -> Type v
@ -624,7 +620,7 @@ app :: Ord v => Type v -> Type v -> Type v
app = Type.app ()
list :: Ord v => Type v -> Type v
list arg = Type.vector () `app` arg
list arg = Type.list () `app` arg
optionalt :: Ord v => Type v -> Type v
optionalt arg = DD.optionalType () `app` arg

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

@ -271,7 +271,7 @@ builtinDataDecls = rs1 ++ rs
, ((), v "Doc.Signature", Type.termLink () `arr` var "Doc")
, ((), v "Doc.Source", Type.refId () linkRef `arr` var "Doc")
, ((), v "Doc.Evaluate", Type.termLink () `arr` var "Doc")
, ((), v "Doc.Join", Type.app () (Type.vector()) (var "Doc") `arr` var "Doc")
, ((), v "Doc.Join", Type.app () (Type.list()) (var "Doc") `arr` var "Doc")
]
link = DataDeclaration
(Unique "a5803524366ead2d7f3780871d48771e8142a3b48802f34a96120e230939c46bd5e182fcbe1fa64e9bff9bf741f3c04")
@ -293,7 +293,7 @@ pattern TuplePattern ps <- (unTuplePattern -> Just ps)
-- some pattern synonyms to make pattern matching on some of these constants more pleasant
pattern DocRef <- ((== docRef) -> True)
pattern DocJoin segs <- Term.App' (Term.Constructor' DocRef DocJoinId) (Term.Sequence' segs)
pattern DocJoin segs <- Term.App' (Term.Constructor' DocRef DocJoinId) (Term.List' segs)
pattern DocBlob txt <- Term.App' (Term.Constructor' DocRef DocBlobId) (Term.Text' txt)
pattern DocLink link <- Term.App' (Term.Constructor' DocRef DocLinkId) link
pattern DocSource link <- Term.App' (Term.Constructor' DocRef DocSourceId) link
@ -318,7 +318,7 @@ unitType, pairType, optionalType, testResultType,
:: Ord v => a -> Type v a
unitType a = Type.ref a unitRef
pairType a = Type.ref a pairRef
testResultType a = Type.app a (Type.vector a) (Type.ref a testResultRef)
testResultType a = Type.app a (Type.list a) (Type.ref a testResultRef)
optionalType a = Type.ref a optionalRef
eitherType a = Type.ref a eitherRef
ioErrorType a = Type.ref a ioErrorRef

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

@ -44,6 +44,9 @@ type EffectDeclaration v a = DD.EffectDeclaration v a
-- | this FileCodebase detail lives here, because the interface depends on it 🙃
type CodebasePath = FilePath
-- | Abstract interface to a user's codebase.
--
-- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem.
data Codebase m v a =
Codebase { getTerm :: Reference.Id -> m (Maybe (Term v a))
, getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a))

20
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -58,10 +58,11 @@ module Unison.Codebase.Branch
, stepManyAtM
, modifyAtM
-- * Branch terms/types
-- ** Term/type lenses
-- * Branch terms/types/edits
-- ** Term/type/edits lenses
, terms
, types
, edits
-- ** Term/type queries
, deepReferents
, deepTypeReferences
@ -158,6 +159,8 @@ import Unison.HashQualified (HashQualified)
import qualified Unison.LabeledDependency as LD
import Unison.LabeledDependency (LabeledDependency)
-- | A node in the Unison namespace hierarchy
-- along with its history.
newtype Branch m = Branch { _history :: UnwrappedBranch m }
deriving (Eq, Ord)
type UnwrappedBranch m = Causal m Raw (Branch0 m)
@ -168,10 +171,19 @@ type EditHash = Hash.Hash
-- Star3 r n Metadata.Type (Metadata.Type, Metadata.Value)
type Star r n = Metadata.Star r n
-- | A node in the Unison namespace hierarchy.
--
-- '_terms' and '_types' are the declarations at this level.
-- '_children' are the nodes one level below us.
-- '_edits' are the 'Patch's stored at this node in the code.
--
-- The @deep*@ fields are derived from the four above.
data Branch0 m = Branch0
{ _terms :: Star Referent NameSegment
, _types :: Star Reference NameSegment
, _children :: Map NameSegment (Branch m)
-- ^ Note the 'Branch' here, not 'Branch0'.
-- Every level in the tree has a history.
, _edits :: Map NameSegment (EditHash, m Patch)
-- names and metadata for this branch and its children
-- (ref, (name, value)) iff ref has metadata `value` at name `name`
@ -235,9 +247,9 @@ findHistoricalSHs = findInHistory
-- This stops searching for a given HashQualified once it encounters
-- any term or type in any Branch0 that satisfies that HashQualified.
findHistoricalHQs :: Monad m
=> Set HashQualified
=> Set (HashQualified Name)
-> Branch m
-> m (Set HashQualified, Names0)
-> m (Set (HashQualified Name), Names0)
findHistoricalHQs = findInHistory
(\hq r n -> HQ.matchesNamedReferent n r hq)
(\hq r n -> HQ.matchesNamedReference n r hq)

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

@ -14,7 +14,7 @@ import qualified Unison.Referent as Referent
import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import Unison.Reference (Reference)
import Unison.HashQualified' (HashQualified'(NameOnly, HashQualified))
import Unison.HashQualified' (HashQualified(NameOnly, HashQualified))
import qualified Unison.HashQualified' as HQ'
import qualified Unison.ShortHash as SH
import qualified Unison.Util.Relation as R

4
parser-typechecker/src/Unison/Codebase/Causal.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
module Unison.Codebase.Causal where
import Unison.Prelude
@ -39,7 +41,7 @@ import qualified Data.Set as Set
-}
newtype RawHash a = RawHash { unRawHash :: Hash }
deriving (Eq, Ord)
deriving (Eq, Ord, Generic)
instance Show (RawHash a) where
show = show . unRawHash

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

@ -31,7 +31,7 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32)
(Term.constructor a guidTypeRef 0)
(Term.app a
(Term.builtin a "Bytes.fromList")
(Term.seq a (map (Term.nat a . fromIntegral) bytes)))
(Term.list a (map (Term.nat a . fromIntegral) bytes)))
[(authorRef, authorTerm)] = hashAndWrangle "author" $
Term.apps

86
parser-typechecker/src/Unison/Codebase/Editor/Command.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
module Unison.Codebase.Editor.Command (
@ -7,11 +8,17 @@ module Unison.Codebase.Editor.Command (
Source,
SourceName,
TypecheckingResult,
LoadSourceResult(..)
LoadSourceResult(..),
commandName
) where
import Unison.Prelude
-- TODO: Don't import backend, but move dependencies to own modules
import Unison.Server.Backend ( DefinitionResults
, ShallowListEntry
, BackendError
)
import Data.Configurator.Types ( Configured )
import Unison.Codebase.Editor.Output
@ -41,7 +48,13 @@ import Unison.Type ( Type )
import Unison.Codebase.ShortBranchHash
( ShortBranchHash )
import Unison.Codebase.Editor.AuthorInfo (AuthorInfo)
import Unison.Codebase.Path (Path)
import qualified Unison.Codebase.Path as Path
import qualified Unison.HashQualified as HQ
import Unison.Name (Name)
import Unison.Server.QueryResult (QueryResult)
import qualified Unison.Server.SearchResult as SR
import qualified Unison.Server.SearchResult' as SR'
type AmbientAbilities v = [Type v Ann]
type SourceName = Text
@ -57,8 +70,28 @@ type TypecheckingResult v =
(Either Names0 (UF.TypecheckedUnisonFile v Ann))
data Command m i v a where
-- Escape hatch.
Eval :: m a -> Command m i v a
HQNameQuery
:: Maybe Path
-> Branch m
-> [HQ.HashQualified Name]
-> Command m i v QueryResult
LoadSearchResults
:: [SR.SearchResult] -> Command m i v [SR'.SearchResult' v Ann]
GetDefinitionsBySuffixes
:: Maybe Path
-> Branch m
-> [HQ.HashQualified Name]
-> Command m i v (Either BackendError (DefinitionResults v))
FindShallow
:: Path.Absolute
-> Command m i v (Either BackendError [ShallowListEntry v Ann])
ConfigLookup :: Configured a => Text -> Command m i v (Maybe a)
Input :: Command m i v i
@ -190,3 +223,52 @@ data Command m i v a where
RuntimeMain :: Command m i v (Type v Ann)
RuntimeTest :: Command m i v (Type v Ann)
commandName :: Command m i v a -> String
commandName = \case
Eval{} -> "Eval"
ConfigLookup{} -> "ConfigLookup"
Input -> "Input"
Notify{} -> "Notify"
NotifyNumbered{} -> "NotifyNumbered"
AddDefsToCodebase{} -> "AddDefsToCodebase"
CodebaseHashLength -> "CodebaseHashLength"
TypeReferencesByShortHash{} -> "TypeReferencesByShortHash"
TermReferencesByShortHash{} -> "TermReferencesByShortHash"
TermReferentsByShortHash{} -> "TermReferentsByShortHash"
BranchHashLength -> "BranchHashLength"
BranchHashesByPrefix{} -> "BranchHashesByPrefix"
ParseType{} -> "ParseType"
LoadSource{} -> "LoadSource"
Typecheck{} -> "Typecheck"
TypecheckFile{} -> "TypecheckFile"
Evaluate{} -> "Evaluate"
Evaluate1{} -> "Evaluate1"
PutWatch{} -> "PutWatch"
LoadWatches{} -> "LoadWatches"
LoadLocalRootBranch -> "LoadLocalRootBranch"
LoadLocalBranch{} -> "LoadLocalBranch"
ViewRemoteBranch{} -> "ViewRemoteBranch"
ImportRemoteBranch{} -> "ImportRemoteBranch"
SyncLocalRootBranch{} -> "SyncLocalRootBranch"
SyncRemoteRootBranch{} -> "SyncRemoteRootBranch"
AppendToReflog{} -> "AppendToReflog"
LoadReflog -> "LoadReflog"
LoadTerm{} -> "LoadTerm"
LoadType{} -> "LoadType"
LoadTypeOfTerm{} -> "LoadTypeOfTerm"
PutTerm{} -> "PutTerm"
PutDecl{} -> "PutDecl"
IsTerm{} -> "IsTerm"
IsType{} -> "IsType"
GetDependents{} -> "GetDependents"
GetTermsOfType{} -> "GetTermsOfType"
GetTermsMentioningType{} -> "GetTermsMentioningType"
Execute{} -> "Execute"
CreateAuthorInfo{} -> "CreateAuthorInfo"
RuntimeMain -> "RuntimeMain"
RuntimeTest -> "RuntimeTest"
HQNameQuery{} -> "HQNameQuery"
LoadSearchResults{} -> "LoadSearchResults"
GetDefinitionsBySuffixes{} -> "GetDefinitionsBySuffixes"
FindShallow{} -> "FindShallow"

15
parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE DeriveGeneric #-}
module Unison.Codebase.Editor.DisplayObject where
import Unison.Prelude
import Unison.ShortHash
data DisplayObject a = BuiltinObject | MissingObject ShortHash | UserObject a
deriving (Eq, Ord, Show, Functor, Generic)
toMaybe :: DisplayObject a -> Maybe a
toMaybe = \case
UserObject a -> Just a
_ -> Nothing

12
parser-typechecker/src/Unison/Codebase/Editor/DisplayThing.hs
View File

@ -1,12 +0,0 @@
module Unison.Codebase.Editor.DisplayThing where
import Unison.Reference as Reference
data DisplayThing a = BuiltinThing | MissingThing Reference.Id | RegularThing a
deriving (Eq, Ord, Show)
toMaybe :: DisplayThing a -> Maybe a
toMaybe = \case
RegularThing a -> Just a
_ -> Nothing

118
parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -1,9 +1,7 @@
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
@ -16,12 +14,13 @@ import Unison.Codebase.Editor.Command
import qualified Unison.Builtin as B
import qualified Unison.Server.Backend as Backend
import qualified Crypto.Random as Random
import Control.Monad.Except ( runExceptT )
import qualified Control.Monad.State as State
import qualified Data.Configurator as Config
import Data.Configurator.Types ( Config )
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Unison.Codebase ( Codebase )
import qualified Unison.Codebase as Codebase
@ -32,7 +31,6 @@ import Unison.Parser ( Ann )
import qualified Unison.Parser as Parser
import qualified Unison.Parsers as Parsers
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Codebase.Runtime as Runtime
import Unison.Codebase.Runtime (Runtime)
import qualified Unison.Term as Term
@ -91,78 +89,72 @@ commandLine
-> Free (Command IO i v) a
-> IO a
commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase rngGen =
Free.foldWithIndex go
flip State.evalStateT 0 . Free.fold go
where
go :: forall x . Int -> Command IO i v x -> IO x
go i x = case x of
go :: forall x . Command IO i v x -> State.StateT Int IO x
go x = case x of
-- Wait until we get either user input or a unison file update
Eval m -> m
Input -> awaitInput
Notify output -> notifyUser output
NotifyNumbered output -> notifyNumbered output
Eval m -> lift $ m
Input -> lift $ awaitInput
Notify output -> lift $ notifyUser output
NotifyNumbered output -> lift $ notifyNumbered output
ConfigLookup name ->
Config.lookup config name
LoadSource sourcePath -> loadSource sourcePath
lift $ Config.lookup config name
LoadSource sourcePath -> lift $ loadSource sourcePath
Typecheck ambient names sourceName source -> do
-- todo: if guids are being shown to users,
-- not ideal to generate new guid every time
rng <- rngGen i
i <- State.get
State.modify' (+1)
rng <- lift $ rngGen i
let namegen = Parser.uniqueBase32Namegen rng
env = Parser.ParsingEnv namegen names
typecheck ambient codebase env sourceName source
TypecheckFile file ambient -> typecheck' ambient codebase file
Evaluate ppe unisonFile -> evalUnisonFile ppe unisonFile
Evaluate1 ppe term -> eval1 ppe term
LoadLocalRootBranch -> either (const Branch.empty) id <$> Codebase.getRootBranch codebase
LoadLocalBranch h -> fromMaybe Branch.empty <$> Codebase.getBranchForHash codebase h
SyncLocalRootBranch branch -> do
lift $ typecheck ambient codebase env sourceName source
TypecheckFile file ambient -> lift $ typecheck' ambient codebase file
Evaluate ppe unisonFile -> lift $ evalUnisonFile ppe unisonFile
Evaluate1 ppe term -> lift $ eval1 ppe term
LoadLocalRootBranch -> lift $ either (const Branch.empty) id <$> Codebase.getRootBranch codebase
LoadLocalBranch h -> lift $ fromMaybe Branch.empty <$> Codebase.getBranchForHash codebase h
SyncLocalRootBranch branch -> lift $ do
setBranchRef branch
Codebase.putRootBranch codebase branch
ViewRemoteBranch ns ->
runExceptT $ Git.viewRemoteBranch undefined ns
lift $ runExceptT $ Git.viewRemoteBranch undefined ns
ImportRemoteBranch ns syncMode ->
runExceptT $ Git.importRemoteBranch codebase undefined ns syncMode
lift $ runExceptT $ Git.importRemoteBranch codebase undefined ns syncMode
SyncRemoteRootBranch repo branch syncMode ->
runExceptT $ Git.pushGitRootBranch codebase undefined branch repo syncMode
LoadTerm r -> Codebase.getTerm codebase r
LoadType r -> Codebase.getTypeDeclaration codebase r
LoadTypeOfTerm r -> Codebase.getTypeOfTerm codebase r
PutTerm r tm tp -> Codebase.putTerm codebase r tm tp
PutDecl r decl -> Codebase.putTypeDeclaration codebase r decl
PutWatch kind r e -> Codebase.putWatch codebase kind r e
LoadWatches kind rs -> catMaybes <$> traverse go (toList rs) where
lift $ runExceptT $ Git.pushGitRootBranch codebase undefined branch repo syncMode
LoadTerm r -> lift $ Codebase.getTerm codebase r
LoadType r -> lift $ Codebase.getTypeDeclaration codebase r
LoadTypeOfTerm r -> lift $ Codebase.getTypeOfTerm codebase r
PutTerm r tm tp -> lift $ Codebase.putTerm codebase r tm tp
PutDecl r decl -> lift $ Codebase.putTypeDeclaration codebase r decl
PutWatch kind r e -> lift $ Codebase.putWatch codebase kind r e
LoadWatches kind rs -> lift $ catMaybes <$> traverse go (toList rs) where
go (Reference.Builtin _) = pure Nothing
go r@(Reference.DerivedId rid) =
fmap (r,) <$> Codebase.getWatch codebase kind rid
IsTerm r -> Codebase.isTerm codebase r
IsType r -> Codebase.isType codebase r
GetDependents r -> Codebase.dependents codebase r
AddDefsToCodebase unisonFile -> Codebase.addDefsToCodebase codebase unisonFile
GetTermsOfType ty -> Codebase.termsOfType codebase ty
GetTermsMentioningType ty -> Codebase.termsMentioningType codebase ty
CodebaseHashLength -> Codebase.hashLength codebase
IsTerm r -> lift $ Codebase.isTerm codebase r
IsType r -> lift $ Codebase.isType codebase r
GetDependents r -> lift $ Codebase.dependents codebase r
AddDefsToCodebase unisonFile -> lift $ Codebase.addDefsToCodebase codebase unisonFile
GetTermsOfType ty -> lift $ Codebase.termsOfType codebase ty
GetTermsMentioningType ty -> lift $ Codebase.termsMentioningType codebase ty
CodebaseHashLength -> lift $ Codebase.hashLength codebase
-- all builtin and derived type references
TypeReferencesByShortHash sh -> do
fromCodebase <- Codebase.typeReferencesByPrefix codebase sh
let fromBuiltins = Set.filter (\r -> sh == Reference.toShortHash r)
$ B.intrinsicTypeReferences
pure (fromBuiltins <> Set.map Reference.DerivedId fromCodebase)
TypeReferencesByShortHash sh ->
lift $ Backend.typeReferencesByShortHash codebase sh
-- all builtin and derived term references
TermReferencesByShortHash sh -> do
fromCodebase <- Codebase.termReferencesByPrefix codebase sh
let fromBuiltins = Set.filter (\r -> sh == Reference.toShortHash r)
$ B.intrinsicTermReferences
pure (fromBuiltins <> Set.map Reference.DerivedId fromCodebase)
TermReferencesByShortHash sh ->
lift $ Backend.termReferencesByShortHash codebase sh
-- all builtin and derived term references & type constructors
TermReferentsByShortHash sh -> do
fromCodebase <- Codebase.termReferentsByPrefix codebase sh
let fromBuiltins = Set.map Referent.Ref
. Set.filter (\r -> sh == Reference.toShortHash r)
$ B.intrinsicTermReferences
pure (fromBuiltins <> Set.map (fmap Reference.DerivedId) fromCodebase)
BranchHashLength -> Codebase.branchHashLength codebase
BranchHashesByPrefix h -> Codebase.branchHashesByPrefix codebase h
TermReferentsByShortHash sh ->
lift $ Backend.termReferentsByShortHash codebase sh
BranchHashLength ->
lift $ Codebase.branchHashLength codebase
BranchHashesByPrefix h ->
lift $ Codebase.branchHashesByPrefix codebase h
ParseType names (src, _) -> pure $
Parsers.parseType (Text.unpack src) (Parser.ParsingEnv mempty names)
RuntimeMain -> pure $ Runtime.mainType rt
@ -174,10 +166,16 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
-- pure $ Branch.append b0 b
Execute ppe uf ->
evalUnisonFile ppe uf
AppendToReflog reason old new -> Codebase.appendReflog codebase reason old new
LoadReflog -> Codebase.getReflog codebase
lift $ evalUnisonFile ppe uf
AppendToReflog reason old new -> lift $ Codebase.appendReflog codebase reason old new
LoadReflog -> lift $ Codebase.getReflog codebase
CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Parser.External t
HQNameQuery mayPath branch query ->
lift $ Backend.hqNameQuery mayPath branch codebase query
LoadSearchResults srs -> lift $ Backend.loadSearchResults codebase srs
GetDefinitionsBySuffixes mayPath branch query ->
lift . runExceptT $ Backend.definitionsBySuffixes mayPath branch codebase query
FindShallow path -> lift . runExceptT $ Backend.findShallow codebase path
eval1 :: PPE.PrettyPrintEnv -> Term v Ann -> _
eval1 ppe tm = do
@ -240,7 +238,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
-- loadDefinitions :: Monad m => Codebase m v a -> Set Reference
-- -> m ( [(Reference, Maybe (Type v a))],
-- [(Reference, DisplayThing (Decl v a))] )
-- [(Reference, DisplayObject (Decl v a))] )
-- loadDefinitions code refs = do
-- termRefs <- filterM (Codebase.isTerm code) (toList refs)
-- terms <- forM termRefs $ \r -> (r,) <$> Codebase.getTypeOfTerm code r

559
parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -21,11 +21,15 @@ where
import Unison.Prelude
-- TODO: Don't import backend
import qualified Unison.Server.Backend as Backend
import Unison.Server.QueryResult
import Unison.Server.Backend (ShallowListEntry(..))
import qualified Unison.Codebase.MainTerm as MainTerm
import Unison.Codebase.Editor.Command
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.DisplayThing
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Editor.Output as Output
import Unison.Codebase.Editor.SlurpResult (SlurpResult(..))
import qualified Unison.Codebase.Editor.SlurpResult as Slurp
@ -41,8 +45,7 @@ import Control.Monad.Except ( ExceptT(..), runExceptT, withE
import Data.Bifunctor ( second, first )
import Data.Configurator ()
import qualified Data.List as List
import Data.List ( partition )
import Data.List.Extra ( nubOrd, sort )
import Data.List.Extra ( nubOrd )
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Text.Megaparsec as P
@ -64,8 +67,9 @@ import Unison.Codebase.Path ( Path
, Path'(..) )
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.Reflog as Reflog
import Unison.Codebase.SearchResult ( SearchResult )
import qualified Unison.Codebase.SearchResult as SR
import Unison.Server.SearchResult ( SearchResult )
import qualified Unison.Server.SearchResult as SR
import qualified Unison.Server.SearchResult' as SR'
import qualified Unison.Codebase.ShortBranchHash as SBH
import qualified Unison.Codebase.SyncMode as SyncMode
import qualified Unison.Builtin.Decls as DD
@ -106,16 +110,12 @@ import qualified Unison.Typechecker as Typechecker
import qualified Unison.PrettyPrintEnv as PPE
import Unison.Runtime.IOSource ( isTest )
import qualified Unison.Runtime.IOSource as IOSource
import qualified Unison.Util.Star3 as Star3
import qualified Unison.Util.Monoid as Monoid
import Unison.UnisonFile (TypecheckedUnisonFile)
import qualified Unison.Codebase.Editor.TodoOutput as TO
import qualified Unison.Lexer as L
import Unison.Codebase.Editor.SearchResult' (SearchResult')
import qualified Unison.Codebase.Editor.SearchResult' as SR'
import qualified Unison.LabeledDependency as LD
import Unison.LabeledDependency (LabeledDependency)
import Unison.Term (Term)
import Unison.Type (Type)
import qualified Unison.Builtin as Builtin
import qualified Unison.Builtin.Terms as Builtin
@ -183,6 +183,9 @@ type Action' m v = Action m (Either Event Input) v
defaultPatchNameSegment :: NameSegment
defaultPatchNameSegment = "patch"
prettyPrintEnvDecl :: Names -> Action' m v PPE.PrettyPrintEnvDecl
prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns)
loop :: forall m v . (Monad m, Var v) => Action m (Either Event Input) v ()
loop = do
uf <- use latestTypecheckedFile
@ -194,6 +197,8 @@ loop = do
hqLength <- eval CodebaseHashLength
sbhLength <- eval BranchHashLength
let
currentPath'' = Path.unabsolute currentPath'
hqNameQuery q = eval $ HQNameQuery (Just currentPath'') root' q
sbh = SBH.fromHash sbhLength
root0 = Branch.head root'
currentBranch0 = Branch.head currentBranch'
@ -219,7 +224,7 @@ loop = do
getHQ'Terms p = BranchUtil.getTerm (resolveSplit' p) root0
getHQ'Types :: Path.HQSplit' -> Set Reference
getHQ'Types p = BranchUtil.getType (resolveSplit' p) root0
getHQTerms :: HQ.HashQualified -> Action' m v (Set Referent)
getHQTerms :: HQ.HashQualified Name -> Action' m v (Set Referent)
getHQTerms hq = case hq of
HQ.NameOnly n -> let
-- absolute-ify the name, then lookup in deepTerms of root
@ -232,6 +237,9 @@ loop = do
where
hashOnly sh = eval $ TermReferentsByShortHash sh
basicPrettyPrintNames0 =
Backend.basicPrettyPrintNames0 root' (Path.unabsolute currentPath')
resolveHHQS'Types :: HashOrHQSplit' -> Action' m v (Set Reference)
resolveHHQS'Types = either
(eval . TypeReferencesByShortHash)
@ -261,7 +269,7 @@ loop = do
L.Hash sh -> Just (HQ.HashOnly sh)
_ -> Nothing
hqs = Set.fromList . mapMaybe (getHQ . L.payload) $ tokens
parseNames :: Names <- makeHistoricalParsingNames hqs
let parseNames = Backend.getCurrentParseNames currentPath'' root'
latestFile .= Just (Text.unpack sourceName, False)
latestTypecheckedFile .= Nothing
Result notes r <- eval $ Typecheck ambient parseNames sourceName lexed
@ -324,39 +332,6 @@ loop = do
typeConflicted src = nameConflicted src Set.empty
termConflicted src tms = nameConflicted src tms Set.empty
hashConflicted src = respond . HashAmbiguous src
hqNameQuery' doSuffixify hqs = do
let (hqnames, hashes) = partition (isJust . HQ.toName) hqs
termRefs <- filter (not . Set.null . snd) . zip hashes <$> traverse
(eval . TermReferentsByShortHash)
(catMaybes (HQ.toHash <$> hashes))
typeRefs <- filter (not . Set.null . snd) . zip hashes <$> traverse
(eval . TypeReferencesByShortHash)
(catMaybes (HQ.toHash <$> hashes))
parseNames0 <- makeHistoricalParsingNames $ Set.fromList hqnames
let
mkTermResult n r = SR.termResult (HQ'.fromHQ' n) r Set.empty
mkTypeResult n r = SR.typeResult (HQ'.fromHQ' n) r Set.empty
termResults =
(\(n, tms) -> (n, toList $ mkTermResult n <$> toList tms)) <$> termRefs
typeResults =
(\(n, tps) -> (n, toList $ mkTypeResult n <$> toList tps)) <$> typeRefs
parseNames = (if doSuffixify then Names3.suffixify else id) parseNames0
resultss = searchBranchExact hqLength parseNames hqnames
missingRefs =
[ x
| x <- hashes
, isNothing (lookup x termRefs) && isNothing (lookup x typeRefs)
]
(misses, hits) =
partition (\(_, results) -> null results) (zip hqs resultss)
results =
List.sort
. uniqueBy SR.toReferent
$ (hits ++ termResults ++ typeResults)
>>= snd
pure (missingRefs ++ (fst <$> misses), results)
hqNameQuery = hqNameQuery' False
hqNameQuerySuffixify = hqNameQuery' True
typeReferences :: [SearchResult] -> [Reference]
typeReferences rs
= [ r | SR.Tp (SR.TypeResult _ r _) <- rs ]
@ -368,7 +343,7 @@ loop = do
doRemoveReplacement from patchPath isTerm = do
let patchPath' = fromMaybe defaultPatchPath patchPath
patch <- getPatchAt patchPath'
(misses', hits) <- hqNameQuery [from]
QueryResult misses' hits <- hqNameQuery [from]
let tpRefs = Set.fromList $ typeReferences hits
tmRefs = Set.fromList $ termReferences hits
misses = Set.difference (Set.fromList misses') if isTerm
@ -517,6 +492,7 @@ loop = do
viewRemoteBranch ns = ExceptT . eval $ ViewRemoteBranch ns
syncRemoteRootBranch repo b mode =
ExceptT . eval $ SyncRemoteRootBranch repo b mode
loadSearchResults = eval . LoadSearchResults
handleFailedDelete failed failedDependents = do
failed <- loadSearchResults $ SR.fromNames failed
failedDependents <- loadSearchResults $ SR.fromNames failedDependents
@ -571,7 +547,7 @@ loop = do
-- e.g. `Metadata.insert` is passed to add metadata links.
manageLinks :: Bool
-> [(Path', HQ'.HQSegment)]
-> [HQ.HashQualified]
-> [HQ.HashQualified Name]
-> (forall r. Ord r
=> (r, Metadata.Type, Metadata.Value)
-> Branch.Star r NameSegment
@ -601,8 +577,10 @@ loop = do
getTypes p = BranchUtil.getType (resolveSplit' p) r0
!srcle = toList . getTerms =<< srcs
!srclt = toList . getTypes =<< srcs
names0 <- basicPrettyPrintNames0
ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (Names names0 mempty)
ppe = Backend.basicSuffixifiedNames
sbhLength
newRoot
(Path.unabsolute currentPath')
case mdl of
[r@(Referent.Ref mdValue)] -> do
mdType <- eval $ LoadTypeOfTerm mdValue
@ -988,7 +966,7 @@ loop = do
(Nothing, Just as) -> (missingSrcs, actions ++ as)
(Just as1, Just as2) -> (missingSrcs, actions ++ as1 ++ as2)
fixupOutput :: Path.HQSplit -> HQ.HashQualified
fixupOutput :: Path.HQSplit -> HQ.HashQualified Name
fixupOutput = fmap Path.toName . HQ'.toHQ . Path.unsplitHQ
NamesI thing -> do
@ -1000,12 +978,12 @@ loop = do
Names.filterByHQs (Set.singleton $ HQ'.HashQualified n sh) parseNames0
HQ.NameOnly n ->
Names.filterByHQs (Set.singleton $ HQ'.NameOnly n) parseNames0
printNames0 <- basicPrettyPrintNames0
let printNames = Names printNames0 mempty
let terms' ::Set (Referent, Set HQ'.HashQualified)
let printNames0 = basicPrettyPrintNames0
printNames = Names printNames0 mempty
terms' ::Set (Referent, Set (HQ'.HashQualified Name))
terms' = (`Set.map` Names.termReferents filtered) $
\r -> (r, Names3.termName hqLength r printNames)
types' :: Set (Reference, Set HQ'.HashQualified)
types' :: Set (Reference, Set (HQ'.HashQualified Name))
types' = (`Set.map` Names.typeReferences filtered) $
\r -> (r, Names3.typeName hqLength r printNames)
respond $ ListNames hqLength (toList types') (toList terms')
@ -1052,7 +1030,7 @@ loop = do
(ppe, out) <- getLinks input src (Left $ Set.singleton DD.docRef)
lift case out of
[(_name, ref, _tm)] -> do
names <- basicPrettyPrintNames0
let names = basicPrettyPrintNames0
doDisplay ConsoleLocation (Names3.Names names mempty) (Referent.Ref ref)
out -> do
numberedArgs .= fmap (HQ.toString . view _1) out
@ -1120,10 +1098,10 @@ loop = do
DeleteTermI hq -> delete getHQ'Terms (const Set.empty) hq
DisplayI outputLoc hq -> do
parseNames0 <- (`Names3.Names` mempty) <$> basicPrettyPrintNames0
-- use suffixed names for resolving the argument to display
let parseNames = Names3.suffixify parseNames0
let results = Names3.lookupHQTerm hq parseNames
let parseNames0 = (`Names3.Names` mempty) basicPrettyPrintNames0
-- use suffixed names for resolving the argument to display
parseNames = Names3.suffixify parseNames0
results = Names3.lookupHQTerm hq parseNames
if Set.null results then
respond $ SearchTermsNotFound [hq]
else if Set.size results > 1 then
@ -1132,70 +1110,27 @@ loop = do
else doDisplay outputLoc parseNames0 (Set.findMin results)
ShowDefinitionI outputLoc query -> do
(misses, results) <- hqNameQuerySuffixify query
results' <- loadSearchResults results
let termTypes :: Map.Map Reference (Type v Ann)
termTypes =
Map.fromList
[ (r, t) | SR'.Tm _ (Just t) (Referent.Ref r) _ <- results' ]
(collatedTypes, collatedTerms) = collateReferences
(mapMaybe SR'.tpReference results')
(mapMaybe SR'.tmReferent results')
-- load the `collatedTerms` and types into a Map Reference.Id Term/Type
-- for later
loadedDerivedTerms <-
fmap (Map.fromList . catMaybes) . for (toList collatedTerms) $ \case
Reference.DerivedId i -> fmap (i,) <$> eval (LoadTerm i)
Reference.Builtin{} -> pure Nothing
loadedDerivedTypes <-
fmap (Map.fromList . catMaybes) . for (toList collatedTypes) $ \case
Reference.DerivedId i -> fmap (i,) <$> eval (LoadType i)
Reference.Builtin{} -> pure Nothing
-- Populate DisplayThings for the search results, in anticipation of
-- displaying the definitions.
loadedDisplayTerms :: Map Reference (DisplayThing (Term v Ann)) <-
fmap Map.fromList . for (toList collatedTerms) $ \case
r@(Reference.DerivedId i) -> do
let tm = Map.lookup i loadedDerivedTerms
-- We add a type annotation to the term using if it doesn't
-- already have one that the user provided
pure . (r, ) $ case liftA2 (,) tm (Map.lookup r termTypes) of
Nothing -> MissingThing i
Just (tm, typ) -> case tm of
Term.Ann' _ _ -> RegularThing tm
_ -> RegularThing (Term.ann (ABT.annotation tm) tm typ)
r@(Reference.Builtin _) -> pure (r, BuiltinThing)
let loadedDisplayTypes :: Map Reference (DisplayThing (DD.Decl v Ann))
loadedDisplayTypes =
Map.fromList . (`fmap` toList collatedTypes) $ \case
r@(Reference.DerivedId i) ->
(r,) . maybe (MissingThing i) RegularThing
$ Map.lookup i loadedDerivedTypes
r@(Reference.Builtin _) -> (r, BuiltinThing)
-- the SR' deps include the result term/type names, and the
let deps = foldMap SR'.labeledDependencies results'
<> foldMap Term.labeledDependencies loadedDerivedTerms
printNames <- makePrintNamesFromLabeled' deps
-- We might like to make sure that the user search terms get used as
-- the names in the pretty-printer, but the current implementation
-- doesn't.
ppe <- prettyPrintEnvDecl printNames
let loc = case outputLoc of
ConsoleLocation -> Nothing
FileLocation path -> Just path
LatestFileLocation -> fmap fst latestFile' <|> Just "scratch.u"
do
unless (null loadedDisplayTypes && null loadedDisplayTerms) $
eval . Notify $
DisplayDefinitions loc ppe loadedDisplayTypes loadedDisplayTerms
unless (null misses) $
eval . Notify $ SearchTermsNotFound misses
-- We set latestFile to be programmatically generated, if we
-- are viewing these definitions to a file - this will skip the
-- next update for that file (which will happen immediately)
latestFile .= ((, True) <$> loc)
res <- eval $ GetDefinitionsBySuffixes (Just currentPath'') root' query
case res of
Left e -> handleBackendError e
Right (Backend.DefinitionResults terms types misses) -> do
let loc = case outputLoc of
ConsoleLocation -> Nothing
FileLocation path -> Just path
LatestFileLocation ->
fmap fst latestFile' <|> Just "scratch.u"
printNames =
Backend.getCurrentPrettyNames currentPath'' root'
ppe = PPE.fromNamesDecl hqLength printNames
unless (null types && null terms) $
eval . Notify $
DisplayDefinitions loc ppe types terms
unless (null misses) $
eval . Notify $ SearchTermsNotFound misses
-- We set latestFile to be programmatically generated, if we
-- are viewing these definitions to a file - this will skip the
-- next update for that file (which will happen immediately)
latestFile .= ((, True) <$> loc)
FindPatchI -> do
let patches =
[ Path.toName $ Path.snoc p seg
@ -1205,86 +1140,62 @@ loop = do
numberedArgs .= fmap Name.toString patches
FindShallowI pathArg -> do
prettyPrintNames0 <- basicPrettyPrintNames0
ppe <- fmap PPE.suffixifiedPPE . prettyPrintEnvDecl $ Names prettyPrintNames0 mempty
let pathArgAbs = resolveToAbsolute pathArg
b0 <- Branch.head <$> getAt pathArgAbs
let
hqTerm b0 ns r =
let refs = Star3.lookupD1 ns . _terms $ b0
in case length refs of
1 -> HQ'.fromName ns
_ -> HQ'.take hqLength $ HQ'.fromNamedReferent ns r
hqType b0 ns r =
let refs = Star3.lookupD1 ns . _types $ b0
in case length refs of
1 -> HQ'.fromName ns
_ -> HQ'.take hqLength $ HQ'.fromNamedReference ns r
defnCount b =
(R.size . deepTerms $ Branch.head b) +
(R.size . deepTypes $ Branch.head b)
termEntries <- for (R.toList . Star3.d1 $ _terms b0) $
\(r, ns) -> do
ot <- loadReferentType r
pure $ ShallowTermEntry r (hqTerm b0 ns r) ot
let
typeEntries =
[ ShallowTypeEntry r (hqType b0 ns r)
| (r, ns) <- R.toList . Star3.d1 $ _types b0 ]
branchEntries =
[ ShallowBranchEntry ns (defnCount b)
| (ns, b) <- Map.toList $ _children b0 ]
patchEntries =
[ ShallowPatchEntry ns
| (ns, (_h, _mp)) <- Map.toList $ _edits b0 ]
let
entries :: [ShallowListEntry v Ann]
entries = sort $ termEntries ++ typeEntries ++ branchEntries ++ patchEntries
entryToHQString :: ShallowListEntry v Ann -> String
-- caching the result as an absolute path, for easier jumping around
entryToHQString e = fixup $ case e of
ShallowTypeEntry _ hq -> HQ'.toString hq
ShallowTermEntry _ hq _ -> HQ'.toString hq
ShallowBranchEntry ns _ -> NameSegment.toString ns
ShallowPatchEntry ns -> NameSegment.toString ns
ppe = Backend.basicSuffixifiedNames
sbhLength
root'
(Path.fromPath' pathArg)
res <- eval $ FindShallow pathArgAbs
case res of
Left e -> handleBackendError e
Right entries -> do
-- caching the result as an absolute path, for easier jumping around
numberedArgs .= fmap entryToHQString entries
respond $ ListShallow ppe entries
where
fixup s =
if last pathArgStr == '.'
then pathArgStr ++ s
else pathArgStr ++ "." ++ s
pathArgStr = show pathArgAbs
numberedArgs .= fmap entryToHQString entries
respond $ ListShallow ppe entries
where
entryToHQString :: ShallowListEntry v Ann -> String
entryToHQString e =
fixup $ case e of
ShallowTypeEntry _ hq _ -> HQ'.toString hq
ShallowTermEntry _ hq _ _ -> HQ'.toString hq
ShallowBranchEntry ns _ _ -> NameSegment.toString ns
ShallowPatchEntry ns -> NameSegment.toString ns
where
fixup s = case pathArgStr of
"" -> s
p | last p == '.' -> p ++ s
p -> p ++ "." ++ s
pathArgStr = show pathArg
SearchByNameI isVerbose _showAll ws -> do
prettyPrintNames0 <- basicPrettyPrintNames0
let prettyPrintNames0 = basicPrettyPrintNames0
unlessError do
results <- case ws of
-- no query, list everything
[] -> pure . listBranch $ Branch.head currentBranch'
-- type query
":" : ws -> ExceptT (parseSearchType input (unwords ws)) >>= \typ -> ExceptT $ do
let named = Branch.deepReferents root0
matches <- fmap toList . eval $ GetTermsOfType typ
matches <- filter (`Set.member` named) <$>
if null matches then do
respond NoExactTypeMatches
fmap toList . eval $ GetTermsMentioningType typ
else pure matches
let results =
-- in verbose mode, aliases are shown, so we collapse all
-- aliases to a single search result; in non-verbose mode,
-- a separate result may be shown for each alias
(if isVerbose then uniqueBy SR.toReferent else id) $
searchResultsFor prettyPrintNames0 matches []
pure . pure $ results
":" : ws ->
ExceptT (parseSearchType input (unwords ws)) >>= \typ ->
ExceptT $ do
let named = Branch.deepReferents root0
matches <- fmap toList . eval $ GetTermsOfType typ
matches <- filter (`Set.member` named) <$>
if null matches then do
respond NoExactTypeMatches
fmap toList . eval $ GetTermsMentioningType typ
else pure matches
let results =
-- in verbose mode, aliases are shown, so we collapse all
-- aliases to a single search result; in non-verbose mode,
-- a separate result may be shown for each alias
(if isVerbose then uniqueBy SR.toReferent else id) $
searchResultsFor prettyPrintNames0 matches []
pure . pure $ results
-- name query
(map HQ.unsafeFromString -> qs) -> do
ns <- lift basicPrettyPrintNames0
let ns = basicPrettyPrintNames0
let srs = searchBranchScored ns fuzzyNameDistance qs
pure $ uniqueBy SR.toReferent srs
lift do
@ -1315,8 +1226,8 @@ loop = do
ReplaceTermI from to patchPath -> do
let patchPath' = fromMaybe defaultPatchPath patchPath
patch <- getPatchAt patchPath'
(fromMisses', fromHits) <- hqNameQuery [from]
(toMisses', toHits) <- hqNameQuery [to]
QueryResult fromMisses' fromHits <- hqNameQuery [from]
QueryResult toMisses' toHits <- hqNameQuery [to]
let fromRefs = termReferences fromHits
toRefs = termReferences toHits
-- Type hits are term misses
@ -1363,8 +1274,8 @@ loop = do
(frs, _) -> ambiguous from frs
ReplaceTypeI from to patchPath -> do
let patchPath' = fromMaybe defaultPatchPath patchPath
(fromMisses', fromHits) <- hqNameQuery [from]
(toMisses', toHits) <- hqNameQuery [to]
QueryResult fromMisses' fromHits <- hqNameQuery [from]
QueryResult toMisses' toHits <- hqNameQuery [to]
patch <- getPatchAt patchPath'
let fromRefs = typeReferences fromHits
toRefs = typeReferences toHits
@ -1558,12 +1469,12 @@ loop = do
testRefs = Set.fromList [ r | Referent.Ref r <- toList testTerms ]
oks results =
[ (r, msg)
| (r, Term.Sequence' ts) <- Map.toList results
| (r, Term.List' ts) <- Map.toList results
, Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts
, cid == DD.okConstructorId && ref == DD.testResultRef ]
fails results =
[ (r, msg)
| (r, Term.Sequence' ts) <- Map.toList results
| (r, Term.List' ts) <- Map.toList results
, Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts
, cid == DD.failConstructorId && ref == DD.testResultRef ]
cachedTests <- fmap Map.fromList . eval $ LoadWatches UF.TestWatch testRefs
@ -1617,12 +1528,17 @@ loop = do
unless updated (respond $ NothingToPatch patchPath scopePath)
ExecuteI main -> addRunMain main uf >>= \case
Nothing -> do
names0 <- basicPrettyPrintNames0
NoTermWithThatName -> do
let names0 = basicPrettyPrintNames0
ppe <- prettyPrintEnv (Names3.Names names0 mempty)
mainType <- eval RuntimeMain
respond $ NoMainFunction main ppe [mainType]
Just unisonFile -> do
TermHasBadType ty -> do
let names0 = basicPrettyPrintNames0
ppe <- prettyPrintEnv (Names3.Names names0 mempty)
mainType <- eval RuntimeMain
respond $ BadMainFunction main ty ppe [mainType]
RunMainSuccess unisonFile -> do
ppe <- executePPE unisonFile
e <- eval $ Execute ppe unisonFile
@ -1632,7 +1548,7 @@ loop = do
IOTestI main -> do
testType <- eval RuntimeTest
parseNames0 <- (`Names3.Names` mempty) <$> basicPrettyPrintNames0
parseNames0 <- (`Names3.Names` mempty) <$> basicPrettyPrintNames0A
ppe <- prettyPrintEnv parseNames0
-- use suffixed names for resolving the argument to display
let
@ -1640,12 +1556,12 @@ loop = do
oks results =
[ (r, msg)
| (r, Term.Sequence' ts) <- results
| (r, Term.List' ts) <- results
, Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts
, cid == DD.okConstructorId && ref == DD.testResultRef ]
fails results =
[ (r, msg)
| (r, Term.Sequence' ts) <- results
| (r, Term.List' ts) <- results
, Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts
, cid == DD.failConstructorId && ref == DD.testResultRef ]
@ -1860,7 +1776,7 @@ loop = do
_ -> pure ()
-- todo: compare to `getHQTerms` / `getHQTypes`. Is one universally better?
resolveHQToLabeledDependencies :: Functor m => HQ.HashQualified -> Action' m v (Set LabeledDependency)
resolveHQToLabeledDependencies :: Functor m => HQ.HashQualified Name -> Action' m v (Set LabeledDependency)
resolveHQToLabeledDependencies = \case
HQ.NameOnly n -> do
parseNames <- Names3.suffixify0 <$> basicParseNames0
@ -1904,7 +1820,7 @@ getLinks :: (Var v, Monad m)
(Action' m v)
(PPE.PrettyPrintEnv,
-- e.g. ("Foo.doc", #foodoc, Just (#builtin.Doc)
[(HQ.HashQualified, Reference, Maybe (Type v Ann))])
[(HQ.HashQualified Name, Reference, Maybe (Type v Ann))])
getLinks input src mdTypeStr = ExceptT $ do
let go = fmap Right . getLinks' src
case mdTypeStr of
@ -1919,7 +1835,7 @@ getLinks' :: (Var v, Monad m)
-> Maybe (Set Reference) -- return all metadata if empty
-> Action' m v (PPE.PrettyPrintEnv,
-- e.g. ("Foo.doc", #foodoc, Just (#builtin.Doc)
[(HQ.HashQualified, Reference, Maybe (Type v Ann))])
[(HQ.HashQualified Name, Reference, Maybe (Type v Ann))])
getLinks' src selection0 = do
root0 <- Branch.head <$> use root
currentPath' <- use currentPath
@ -2109,16 +2025,16 @@ searchResultsFor ns terms types =
searchBranchScored :: forall score. (Ord score)
=> Names0
-> (Name -> Name -> Maybe score)
-> [HQ.HashQualified]
-> [HQ.HashQualified Name]
-> [SearchResult]
searchBranchScored names0 score queries =
nubOrd . fmap snd . toList $ searchTermNamespace <> searchTypeNamespace
where
searchTermNamespace = foldMap do1query queries
where
do1query :: HQ.HashQualified -> Set (Maybe score, SearchResult)
do1query :: HQ.HashQualified Name -> Set (Maybe score, SearchResult)
do1query q = foldMap (score1hq q) (R.toList . Names.terms $ names0)
score1hq :: HQ.HashQualified -> (Name, Referent) -> Set (Maybe score, SearchResult)
score1hq :: HQ.HashQualified Name -> (Name, Referent) -> Set (Maybe score, SearchResult)
score1hq query (name, ref) = case query of
HQ.NameOnly qn ->
pair qn
@ -2134,9 +2050,9 @@ searchBranchScored names0 score queries =
Nothing -> mempty
searchTypeNamespace = foldMap do1query queries
where
do1query :: HQ.HashQualified -> Set (Maybe score, SearchResult)
do1query :: HQ.HashQualified Name -> Set (Maybe score, SearchResult)
do1query q = foldMap (score1hq q) (R.toList . Names.types $ names0)
score1hq :: HQ.HashQualified -> (Name, Reference) -> Set (Maybe score, SearchResult)
score1hq :: HQ.HashQualified Name -> (Name, Reference) -> Set (Maybe score, SearchResult)
score1hq query (name, ref) = case query of
HQ.NameOnly qn ->
pair qn
@ -2151,46 +2067,19 @@ searchBranchScored names0 score queries =
Just score -> Set.singleton (Just score, result)
Nothing -> mempty
-- Separates type references from term references and returns types and terms,
-- respectively. For terms that are constructors, turns them into their data
-- types.
collateReferences
:: Foldable f
=> Foldable g
=> f Reference -- types requested
-> g Referent -- terms requested, including ctors
-> (Set Reference, Set Reference)
collateReferences (toList -> types) (toList -> terms) =
let terms' = [ r | Referent.Ref r <- terms ]
types' = [ r | Referent.Con r _ _ <- terms ]
in (Set.fromList types' <> Set.fromList types, Set.fromList terms')
-- | The output list (of lists) corresponds to the query list.
searchBranchExact :: Int -> Names -> [HQ.HashQualified] -> [[SearchResult]]
searchBranchExact len names queries = let
searchTypes :: HQ.HashQualified -> [SearchResult]
searchTypes query =
-- a bunch of references will match a HQ ref.
let refs = toList $ Names3.lookupHQType query names in
refs <&> \r ->
let hqNames = Names3.typeName len r names in
let primaryName =
last . sortOn (\n -> HQ.matchesNamedReference (HQ'.toName n) r query)
$ toList hqNames in
let aliases = Set.delete primaryName hqNames in
SR.typeResult primaryName r aliases
searchTerms :: HQ.HashQualified -> [SearchResult]
searchTerms query =
-- a bunch of references will match a HQ ref.
let refs = toList $ Names3.lookupHQTerm query names in
refs <&> \r ->
let hqNames = Names3.termName len r names in
let primaryName =
last . sortOn (\n -> HQ.matchesNamedReferent (HQ'.toName n) r query)
$ toList hqNames in
let aliases = Set.delete primaryName hqNames in
SR.termResult primaryName r aliases
in [ searchTypes q <> searchTerms q | q <- queries ]
handleBackendError :: Backend.BackendError -> Action m i v ()
handleBackendError = \case
Backend.NoSuchNamespace path ->
respond . BranchNotFound $ Path.absoluteToPath' path
Backend.BadRootBranch e -> respond $ BadRootBranch e
Backend.NoBranchForHash h -> do
sbhLength <- eval BranchHashLength
respond . NoBranchWithHash $ SBH.fromHash sbhLength h
Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh
Backend.AmbiguousBranchHash h hashes ->
respond $ BranchHashAmbiguous h hashes
Backend.MissingSignatureForTerm r ->
respond $ TermMissingType r
respond :: Output v -> Action m i v ()
respond output = eval $ Notify output
@ -2393,8 +2282,13 @@ getEndangeredDependents getDependents toDelete root = do
-- meaning that adds/updates should only contain the selection or its transitive
-- dependencies, any unselected transitive dependencies of the selection will
-- be added to `extraDefinitions`.
applySelection :: forall v a. Var v =>
[HQ'.HashQualified] -> UF.TypecheckedUnisonFile v a -> SlurpResult v -> SlurpResult v
applySelection
:: forall v a
. Var v
=> [HQ'.HashQualified Name]
-> UF.TypecheckedUnisonFile v a
-> SlurpResult v
-> SlurpResult v
applySelection [] _ = id
applySelection hqs file = \sr@SlurpResult{..} ->
sr { adds = adds `SC.intersection` closed
@ -2649,46 +2543,46 @@ doSlurpUpdates typeEdits termEdits deprecated b0 =
oldMd = BranchUtil.getTermMetadataAt split (Referent.Ref old) b0
errorEmptyVar = error "encountered an empty var name"
loadSearchResults :: Ord v => [SR.SearchResult] -> Action m i v [SearchResult' v Ann]
loadSearchResults = traverse loadSearchResult
where
loadSearchResult = \case
SR.Tm (SR.TermResult name r aliases) -> do
typ <- loadReferentType r
pure $ SR'.Tm name typ r aliases
SR.Tp (SR.TypeResult name r aliases) -> do
dt <- loadTypeDisplayThing r
pure $ SR'.Tp name dt r aliases
loadDisplayInfo ::
Set Reference -> Action m i v ([(Reference, Maybe (Type v Ann))]
,[(Reference, DisplayThing (DD.Decl v Ann))])
,[(Reference, DisplayObject (DD.Decl v Ann))])
loadDisplayInfo refs = do
termRefs <- filterM (eval . IsTerm) (toList refs)
typeRefs <- filterM (eval . IsType) (toList refs)
terms <- forM termRefs $ \r -> (r,) <$> eval (LoadTypeOfTerm r)
types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayThing r
types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject r
pure (terms, types)
loadReferentType :: Referent -> Action m i v (Maybe (Type v Ann))
loadReferentType = \case
Referent.Ref r -> eval $ LoadTypeOfTerm r
Referent.Con r cid _ -> getTypeOfConstructor r cid
where
getTypeOfConstructor :: Reference -> Int -> Action m i v (Maybe (Type v Ann))
getTypeOfConstructor (Reference.DerivedId r) cid = do
maybeDecl <- eval $ LoadType r
pure $ case maybeDecl of
Nothing -> Nothing
Just decl -> DD.typeOfConstructor (either DD.toDataDecl id decl) cid
getTypeOfConstructor r cid =
error $ "Don't know how to getTypeOfConstructor " ++ show r ++ " " ++ show cid
-- Any absolute names in the input which have `currentPath` as a prefix
-- are converted to names relative to current path. all other names are
-- converted to absolute names. For example:
--
-- e.g. if currentPath = .foo.bar
-- then name foo.bar.baz becomes baz
-- name cat.dog becomes .cat.dog
fixupNamesRelative :: Path.Absolute -> Names0 -> Names0
fixupNamesRelative currentPath' = Names3.map0 fixName where
prefix = Path.toName (Path.unabsolute currentPath')
fixName n = if currentPath' == Path.absoluteEmpty then n else
fromMaybe (Name.makeAbsolute n) (Name.stripNamePrefix prefix n)
loadTypeDisplayThing :: Reference -> Action m i v (DisplayThing (DD.Decl v Ann))
loadTypeDisplayThing = \case
Reference.Builtin _ -> pure BuiltinThing
makeHistoricalParsingNames ::
Monad m => Set (HQ.HashQualified Name) -> Action' m v Names
makeHistoricalParsingNames lexedHQs = do
rawHistoricalNames <- findHistoricalHQs lexedHQs
basicNames0 <- basicParseNames0
currentPath <- use currentPath
pure $ Names basicNames0
(Names3.makeAbsolute0 rawHistoricalNames <>
fixupNamesRelative currentPath rawHistoricalNames)
loadTypeDisplayObject
:: Reference -> Action m i v (DisplayObject (DD.Decl v Ann))
loadTypeDisplayObject = \case
Reference.Builtin _ -> pure BuiltinObject
Reference.DerivedId id ->
maybe (MissingThing id) RegularThing <$> eval (LoadType id)
maybe (MissingObject $ Reference.idToShortHash id) UserObject
<$> eval (LoadType id)
lexedSource :: Monad m => SourceName -> Source -> Action' m v (Names, LexedSource)
lexedSource name src = do
@ -2706,9 +2600,6 @@ lexedSource name src = do
prettyPrintEnv :: Names -> Action' m v PPE.PrettyPrintEnv
prettyPrintEnv ns = eval CodebaseHashLength <&> (`PPE.fromNames` ns)
prettyPrintEnvDecl :: Names -> Action' m v PPE.PrettyPrintEnvDecl
prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns)
parseSearchType :: (Monad m, Var v)
=> Input -> String -> Action' m v (Either (Output v) (Type v Ann))
parseSearchType input typ = fmap Type.removeAllEffectVars <$> parseType input typ
@ -2734,6 +2625,17 @@ makeShadowedPrintNamesFromLabeled
makeShadowedPrintNamesFromLabeled deps shadowing =
Names3.shadowing shadowing <$> makePrintNamesFromLabeled' deps
makePrintNamesFromLabeled'
:: Monad m => Set LabeledDependency -> Action' m v Names
makePrintNamesFromLabeled' deps = do
root <- use root
currentPath <- use currentPath
(_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalRefs
deps
root
basicNames0 <- basicPrettyPrintNames0A
pure $ Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames)
getTermsIncludingHistorical
:: Monad m => Path.HQSplit -> Branch0 m -> Action' m v (Set Referent)
getTermsIncludingHistorical (p, hq) b = case Set.toList refs of
@ -2748,7 +2650,7 @@ getTermsIncludingHistorical (p, hq) b = case Set.toList refs of
-- discards inputs that aren't hashqualified;
-- I'd enforce it with finer-grained types if we had them.
findHistoricalHQs :: Monad m => Set HQ.HashQualified -> Action' m v Names0
findHistoricalHQs :: Monad m => Set (HQ.HashQualified Name) -> Action' m v Names0
findHistoricalHQs lexedHQs0 = do
root <- use root
currentPath <- use currentPath
@ -2770,10 +2672,13 @@ findHistoricalHQs lexedHQs0 = do
(_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalHQs lexedHQs root
pure rawHistoricalNames
makeShadowedPrintNamesFromHQ :: Monad m => Set HQ.HashQualified -> Names0 -> Action' m v Names
basicPrettyPrintNames0A :: Functor m => Action' m v Names0
basicPrettyPrintNames0A = snd <$> basicNames0'
makeShadowedPrintNamesFromHQ :: Monad m => Set (HQ.HashQualified Name) -> Names0 -> Action' m v Names
makeShadowedPrintNamesFromHQ lexedHQs shadowing = do
rawHistoricalNames <- findHistoricalHQs lexedHQs
basicNames0 <- basicPrettyPrintNames0
basicNames0 <- basicPrettyPrintNames0A
currentPath <- use currentPath
-- The basic names go into "current", but are shadowed by "shadowing".
-- They go again into "historical" as a hack that makes them available HQ-ed.
@ -2782,43 +2687,8 @@ makeShadowedPrintNamesFromHQ lexedHQs shadowing = do
shadowing
(Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames))
makePrintNamesFromLabeled'
:: Monad m => Set LabeledDependency -> Action' m v Names
makePrintNamesFromLabeled' deps = do
root <- use root
currentPath <- use currentPath
(_missing, rawHistoricalNames) <- eval . Eval $ Branch.findHistoricalRefs
deps
root
basicNames0 <- basicPrettyPrintNames0
pure $ Names basicNames0 (fixupNamesRelative currentPath rawHistoricalNames)
-- Any absolute names in the input which have `currentPath` as a prefix
-- are converted to names relative to current path. All other names are
-- converted to absolute names. For example:
--
-- e.g. if currentPath = .foo.bar
-- then name foo.bar.baz becomes baz
-- name cat.dog becomes .cat.dog
fixupNamesRelative :: Path.Absolute -> Names0 -> Names0
fixupNamesRelative currentPath' = Names3.map0 fixName where
prefix = Path.toName (Path.unabsolute currentPath')
fixName n = if currentPath' == Path.absoluteEmpty then n else
fromMaybe (Name.makeAbsolute n) (Name.stripNamePrefix prefix n)
makeHistoricalParsingNames ::
Monad m => Set HQ.HashQualified -> Action' m v Names
makeHistoricalParsingNames lexedHQs = do
rawHistoricalNames <- findHistoricalHQs lexedHQs
basicNames0 <- basicParseNames0
currentPath <- use currentPath
pure $ Names basicNames0
(Names3.makeAbsolute0 rawHistoricalNames <>
fixupNamesRelative currentPath rawHistoricalNames)
basicParseNames0, basicPrettyPrintNames0, slurpResultNames0 :: Functor m => Action' m v Names0
basicParseNames0, slurpResultNames0 :: Functor m => Action' m v Names0
basicParseNames0 = fst <$> basicNames0'
basicPrettyPrintNames0 = snd <$> basicNames0'
-- we check the file against everything in the current path
slurpResultNames0 = currentPathNames0
@ -2828,30 +2698,17 @@ currentPathNames0 = do
currentBranch' <- getAt currentPath'
pure $ Branch.toNames0 (Branch.head currentBranch')
-- implementation detail of baseicParseNames0 and basicPrettyPrintNames0
-- implementation detail of basicParseNames0 and basicPrettyPrintNames0
basicNames0' :: Functor m => Action' m v (Names0, Names0)
basicNames0' = do
root' <- use root
currentPath' <- use currentPath
currentBranch' <- getAt currentPath'
let root0 = Branch.head root'
absoluteRootNames0 = Names3.makeAbsolute0 (Branch.toNames0 root0)
currentBranch0 = Branch.head currentBranch'
currentPathNames0 = Branch.toNames0 currentBranch0
-- all names, but with local names in their relative form only, rather
-- than absolute; external names appear as absolute
currentAndExternalNames0 = currentPathNames0 `Names3.unionLeft0` absDot externalNames where
absDot = Names.prefix0 (Name.unsafeFromText "")
externalNames = rootNames `Names.difference` pathPrefixed currentPathNames0
rootNames = Branch.toNames0 root0
pathPrefixed = case Path.unabsolute currentPath' of
Path.Path (toList -> []) -> id
p -> Names.prefix0 (Path.toName p)
-- parsing should respond to local and absolute names
parseNames00 = currentPathNames0 <> absoluteRootNames0
-- pretty-printing should use local names where available
prettyPrintNames00 = currentAndExternalNames0
pure (parseNames00, prettyPrintNames00)
pure $ Backend.basicNames0' root' (Path.unabsolute currentPath')
data AddRunMainResult v
= NoTermWithThatName
| TermHasBadType (Type v Ann)
| RunMainSuccess (TypecheckedUnisonFile v Ann)
-- Given a typechecked file with a main function called `mainName`
-- of the type `'{IO} ()`, adds an extra binding which
@ -2863,7 +2720,7 @@ addRunMain
:: (Monad m, Var v)
=> String
-> Maybe (TypecheckedUnisonFile v Ann)
-> Action' m v (Maybe (TypecheckedUnisonFile v Ann))
-> Action' m v (AddRunMainResult v)
addRunMain mainName Nothing = do
parseNames0 <- basicParseNames0
let loadTypeOfTerm ref = eval $ LoadTypeOfTerm ref
@ -2871,10 +2728,10 @@ addRunMain mainName Nothing = do
mainToFile <$>
MainTerm.getMainTerm loadTypeOfTerm parseNames0 mainName mainType
where
mainToFile (MainTerm.NotAFunctionName _) = Nothing
mainToFile (MainTerm.NotFound _) = Nothing
mainToFile (MainTerm.BadType _) = Nothing
mainToFile (MainTerm.Success hq tm typ) = Just $
mainToFile (MainTerm.NotAFunctionName _) = NoTermWithThatName
mainToFile (MainTerm.NotFound _) = NoTermWithThatName
mainToFile (MainTerm.BadType _ ty) = maybe NoTermWithThatName TermHasBadType ty
mainToFile (MainTerm.Success hq tm typ) = RunMainSuccess $
let v = Var.named (HQ.toText hq) in
UF.typecheckedUnisonFile mempty mempty mempty [("main",[(v, tm, typ)])] -- mempty
addRunMain mainName (Just uf) = do
@ -2886,14 +2743,14 @@ addRunMain mainName (Just uf) = do
v2 = Var.freshIn (Set.fromList [v]) v
a = ABT.annotation tm
in
if Typechecker.isSubtype mainType ty then Just $ let
if Typechecker.isSubtype mainType ty then RunMainSuccess $ let
runMain = DD.forceTerm a a (Term.var a v)
in UF.typecheckedUnisonFile
(UF.dataDeclarationsId' uf)
(UF.effectDeclarationsId' uf)
(UF.topLevelComponents' uf)
(UF.watchComponents uf <> [("main", [(v2, runMain, mainType)])])
else Nothing
else TermHasBadType ty
_ -> addRunMain mainName Nothing
executePPE
@ -2914,7 +2771,7 @@ diffHelper :: Monad m
diffHelper before after = do
hqLength <- eval CodebaseHashLength
diff <- eval . Eval $ BranchDiff.diff0 before after
names0 <- basicPrettyPrintNames0
names0 <- basicPrettyPrintNames0A
ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (Names names0 mempty)
(ppe,) <$>
OBranchDiff.toOutput

38
parser-typechecker/src/Unison/Codebase/Editor/Input.hs
View File

@ -19,9 +19,11 @@ import Unison.ShortHash (ShortHash)
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import qualified Unison.Codebase.ShortBranchHash as SBH
import Unison.Codebase.SyncMode ( SyncMode )
import qualified Data.Text as Text
import Unison.Name ( Name )
import Unison.NameSegment ( NameSegment )
import qualified Data.Text as Text
data Event
= UnisonFileChanged SourceName Source
| IncomingRootBranch (Set Branch.Hash)
@ -63,7 +65,7 @@ data Input
-- > names .foo.bar
-- > names .foo.bar#asdflkjsdf
-- > names #sdflkjsdfhsdf
| NamesI HQ.HashQualified
| NamesI (HQ.HashQualified Name)
| AliasTermI HashOrHQSplit' Path.Split'
| AliasTypeI HashOrHQSplit' Path.Split'
| AliasManyI [Path.HQSplit] Path'
@ -86,20 +88,20 @@ data Input
| ResolveTypeNameI Path.HQSplit'
-- edits stuff:
| LoadI (Maybe FilePath)
| AddI [HQ'.HashQualified]
| PreviewAddI [HQ'.HashQualified]
| UpdateI (Maybe PatchPath) [HQ'.HashQualified]
| PreviewUpdateI [HQ'.HashQualified]
| AddI [HQ'.HashQualified Name]
| PreviewAddI [HQ'.HashQualified Name]
| UpdateI (Maybe PatchPath) [HQ'.HashQualified Name]
| PreviewUpdateI [HQ'.HashQualified Name]
| TodoI (Maybe PatchPath) Path'
| PropagatePatchI PatchPath Path'
| ListEditsI (Maybe PatchPath)
-- -- create and remove update directives
| DeprecateTermI PatchPath Path.HQSplit'
| DeprecateTypeI PatchPath Path.HQSplit'
| ReplaceTermI HQ.HashQualified HQ.HashQualified (Maybe PatchPath)
| ReplaceTypeI HQ.HashQualified HQ.HashQualified (Maybe PatchPath)
| RemoveTermReplacementI HQ.HashQualified (Maybe PatchPath)
| RemoveTypeReplacementI HQ.HashQualified (Maybe PatchPath)
| ReplaceTermI (HQ.HashQualified Name) (HQ.HashQualified Name) (Maybe PatchPath)
| ReplaceTypeI (HQ.HashQualified Name) (HQ.HashQualified Name) (Maybe PatchPath)
| RemoveTermReplacementI (HQ.HashQualified Name) (Maybe PatchPath)
| RemoveTypeReplacementI (HQ.HashQualified Name) (Maybe PatchPath)
| UndoI
-- First `Maybe Int` is cap on number of results, if any
-- Second `Maybe Int` is cap on diff elements shown, if any
@ -107,30 +109,30 @@ data Input
-- execute an IO thunk
| ExecuteI String
-- execute an IO [Result]
| IOTestI HQ.HashQualified
| IOTestI (HQ.HashQualified Name)
| TestI Bool Bool -- TestI showSuccesses showFailures
-- metadata
-- `link metadata definitions` (adds metadata to all of `definitions`)
| LinkI HQ.HashQualified [Path.HQSplit']
| LinkI (HQ.HashQualified Name) [Path.HQSplit']
-- `unlink metadata definitions` (removes metadata from all of `definitions`)
| UnlinkI HQ.HashQualified [Path.HQSplit']
| UnlinkI (HQ.HashQualified Name) [Path.HQSplit']
-- links from <type>
| LinksI Path.HQSplit' (Maybe String)
| CreateAuthorI NameSegment {- identifier -} Text {- name -}
| DisplayI OutputLocation HQ.HashQualified
| DisplayI OutputLocation (HQ.HashQualified Name)
| DocsI Path.HQSplit'
-- other
| SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query
| FindShallowI Path'
| FindPatchI
| ShowDefinitionI OutputLocation [HQ.HashQualified]
| ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified]
| ShowDefinitionI OutputLocation [HQ.HashQualified Name]
| ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name]
| ShowReflogI
| UpdateBuiltinsI
| MergeBuiltinsI
| MergeIOBuiltinsI
| ListDependenciesI HQ.HashQualified
| ListDependentsI HQ.HashQualified
| ListDependenciesI (HQ.HashQualified Name)
| ListDependentsI (HQ.HashQualified Name)
| DebugNumberedArgsI
| DebugBranchHistoryI
| DebugTypecheckedUnisonFileI

64
parser-typechecker/src/Unison/Codebase/Editor/Output.hs
View File

@ -5,7 +5,6 @@ module Unison.Codebase.Editor.Output
, NumberedOutput(..)
, NumberedArgs
, ListDetailed
, ShallowListEntry(..)
, HistoryTail(..)
, TestReportStats(..)
, UndoFailureReason(..)
@ -18,7 +17,9 @@ module Unison.Codebase.Editor.Output
import Unison.Prelude
import Unison.Server.Backend (ShallowListEntry(..))
import Unison.Codebase.Editor.Input
import Unison.Codebase (GetRootBranchError)
import Unison.Codebase.Editor.SlurpResult (SlurpResult(..))
import Unison.Codebase.GitError
import Unison.Codebase.Path (Path', Path)
@ -43,16 +44,15 @@ import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Typechecker.Context as Context
import qualified Unison.UnisonFile as UF
import qualified Unison.Util.Pretty as P
import Unison.Codebase.Editor.DisplayThing (DisplayThing)
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
import qualified Unison.Codebase.Editor.TodoOutput as TO
import Unison.Codebase.Editor.SearchResult' (SearchResult')
import Unison.Server.SearchResult' (SearchResult')
import Unison.Term (Term)
import Unison.Type (Type)
import qualified Unison.Names3 as Names
import qualified Data.Set as Set
import Unison.NameSegment (NameSegment)
import Unison.ShortHash (ShortHash)
import Unison.Var (Var)
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
import Unison.Codebase.Editor.RemoteRepo as RemoteRepo
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
@ -94,6 +94,8 @@ data Output v
| SourceLoadFailed String
-- No main function, the [Type v Ann] are the allowed types
| NoMainFunction String PPE.PrettyPrintEnv [Type v Ann]
-- Main function found, but has improper type
| BadMainFunction String (Type v Ann) PPE.PrettyPrintEnv [Type v Ann]
| BranchEmpty (Either ShortBranchHash Path')
| BranchNotEmpty Path'
| LoadPullRequest RemoteNamespace RemoteNamespace Path' Path' Path' Path'
@ -106,10 +108,10 @@ data Output v
| ParseResolutionFailures String [Names.ResolutionFailure v Ann]
| TypeHasFreeVars (Type v Ann)
| TermAlreadyExists Path.Split' (Set Referent)
| LabeledReferenceAmbiguous Int HQ.HashQualified (Set LabeledDependency)
| LabeledReferenceNotFound HQ.HashQualified
| LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency)
| LabeledReferenceNotFound (HQ.HashQualified Name)
| DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference)
| TermAmbiguous HQ.HashQualified (Set Referent)
| TermAmbiguous (HQ.HashQualified Name) (Set Referent)
| HashAmbiguous ShortHash (Set Referent)
| BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash)
| BranchNotFound Path'
@ -119,7 +121,7 @@ data Output v
| TermNotFound Path.HQSplit'
| TypeNotFound' ShortHash
| TermNotFound' ShortHash
| SearchTermsNotFound [HQ.HashQualified]
| SearchTermsNotFound [HQ.HashQualified Name]
-- ask confirmation before deleting the last branch that contains some defns
-- `Path` is one of the paths the user has requested to delete, and is paired
-- with whatever named definitions would not have any remaining names if
@ -131,11 +133,11 @@ data Output v
| DeleteEverythingConfirmation
| DeletedEverything
| ListNames Int -- hq length to print References
[(Reference, Set HQ'.HashQualified)] -- type match, type names
[(Referent, Set HQ'.HashQualified)] -- term match, term names
[(Reference, Set (HQ'.HashQualified Name))] -- type match, type names
[(Referent, Set (HQ'.HashQualified Name))] -- term match, term names
-- list of all the definitions within this branch
| ListOfDefinitions PPE.PrettyPrintEnv ListDetailed [SearchResult' v Ann]
| ListOfLinks PPE.PrettyPrintEnv [(HQ.HashQualified, Reference, Maybe (Type v Ann))]
| ListOfLinks PPE.PrettyPrintEnv [(HQ.HashQualified Name, Reference, Maybe (Type v Ann))]
| ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann]
| ListOfPatches (Set Name)
-- show the result of add/update
@ -155,8 +157,8 @@ data Output v
-- "display" definitions, possibly to a FilePath on disk (e.g. editing)
| DisplayDefinitions (Maybe FilePath)
PPE.PrettyPrintEnvDecl
(Map Reference (DisplayThing (Decl v Ann)))
(Map Reference (DisplayThing (Term v Ann)))
(Map Reference (DisplayObject (Decl v Ann)))
(Map Reference (DisplayObject (Term v Ann)))
-- | Invariant: there's at least one conflict or edit in the TodoOutput.
| TodoOutput PPE.PrettyPrintEnvDecl (TO.TodoOutput v Ann)
| TestIncrementalOutputStart PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann)
@ -178,10 +180,11 @@ data Output v
| ConfiguredGitUrlParseError PushPull Path' Text String
| ConfiguredGitUrlIncludesShortBranchHash PushPull RemoteRepo ShortBranchHash Path
| DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata
(Map Reference (DisplayThing (Decl v Ann)))
(Map Reference (DisplayThing (Term v Ann)))
(Map Reference (DisplayObject (Decl v Ann)))
(Map Reference (DisplayObject (Term v Ann)))
| MetadataMissingType PPE.PrettyPrintEnv Referent
| MetadataAmbiguous HQ.HashQualified PPE.PrettyPrintEnv [Referent]
| TermMissingType Reference
| MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent]
-- todo: tell the user to run `todo` on the same patch they just used
| NothingToPatch PatchPath Path'
| PatchNeedsToBeConflictFree
@ -204,6 +207,7 @@ data Output v
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
| BadName String
| DefaultMetadataNotification
| BadRootBranch GetRootBranchError
| NoOp
deriving (Show)
@ -211,31 +215,6 @@ data ReflogEntry =
ReflogEntry { hash :: ShortBranchHash, reason :: Text }
deriving (Show)
data ShallowListEntry v a
= ShallowTermEntry Referent HQ'.HQSegment (Maybe (Type v a))
| ShallowTypeEntry Reference HQ'.HQSegment
| ShallowBranchEntry NameSegment Int -- number of child definitions
| ShallowPatchEntry NameSegment
deriving (Eq, Show)
-- requires Var v to derive Eq, which is required by Ord though not by `compare`
instance Var v => Ord (ShallowListEntry v a) where
compare x y = case compare (toNS x) (toNS y) of
EQ -> compare (toHash x) (toHash y)
c -> c
where
toNS = \case
ShallowTermEntry _ hq _ -> HQ'.toName hq
ShallowTypeEntry _ hq -> HQ'.toName hq
ShallowBranchEntry ns _ -> ns
ShallowPatchEntry ns -> ns
toHash :: ShallowListEntry v a -> Maybe ShortHash
toHash = \case
ShallowTermEntry _ hq _ -> HQ'.toHash hq
ShallowTypeEntry _ hq -> HQ'.toHash hq
ShallowBranchEntry _ _ -> Nothing
ShallowPatchEntry _ -> Nothing
data HistoryTail =
EndOfLog ShortBranchHash |
MergeTail ShortBranchHash [ShortBranchHash] |
@ -258,10 +237,12 @@ type SourceFileContents = Text
isFailure :: Ord v => Output v -> Bool
isFailure o = case o of
Success{} -> False
BadRootBranch{} -> True
NoUnisonFile{} -> True
InvalidSourceName{} -> True
SourceLoadFailed{} -> True
NoMainFunction{} -> True
BadMainFunction{} -> True
CreatedNewBranch{} -> False
BranchAlreadyExists{} -> True
PatchAlreadyExists{} -> True
@ -342,6 +323,7 @@ isFailure o = case o of
NoOp -> False
ListDependencies{} -> False
ListDependents{} -> False
TermMissingType{} -> True
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
isNumberedFailure :: NumberedOutput v -> Bool

24
parser-typechecker/src/Unison/Codebase/Editor/Output/BranchDiff.hs
View File

@ -75,24 +75,24 @@ isEmpty BranchDiffOutput{..} =
-- Need to be able to turn a (Name,Reference) into a HashQualified relative to... what.
-- the new namespace?
type TermDisplay v a = (HashQualified, Referent, Maybe (Type v a), MetadataDiff (MetadataDisplay v a))
type TypeDisplay v a = (HashQualified, Reference, Maybe (DeclOrBuiltin v a), MetadataDiff (MetadataDisplay v a))
type TermDisplay v a = (HashQualified Name, Referent, Maybe (Type v a), MetadataDiff (MetadataDisplay v a))
type TypeDisplay v a = (HashQualified Name, Reference, Maybe (DeclOrBuiltin v a), MetadataDiff (MetadataDisplay v a))
type AddedTermDisplay v a = ([(HashQualified, [MetadataDisplay v a])], Referent, Maybe (Type v a))
type AddedTypeDisplay v a = ([(HashQualified, [MetadataDisplay v a])], Reference, Maybe (DeclOrBuiltin v a))
type AddedTermDisplay v a = ([(HashQualified Name, [MetadataDisplay v a])], Referent, Maybe (Type v a))
type AddedTypeDisplay v a = ([(HashQualified Name, [MetadataDisplay v a])], Reference, Maybe (DeclOrBuiltin v a))
type RemovedTermDisplay v a = ([HashQualified], Referent, Maybe (Type v a))
type RemovedTypeDisplay v a = ([HashQualified], Reference, Maybe (DeclOrBuiltin v a))
type RemovedTermDisplay v a = ([HashQualified Name], Referent, Maybe (Type v a))
type RemovedTypeDisplay v a = ([HashQualified Name], Reference, Maybe (DeclOrBuiltin v a))
type SimpleTermDisplay v a = (HashQualified, Referent, Maybe (Type v a))
type SimpleTypeDisplay v a = (HashQualified, Reference, Maybe (DeclOrBuiltin v a))
type SimpleTermDisplay v a = (HashQualified Name, Referent, Maybe (Type v a))
type SimpleTypeDisplay v a = (HashQualified Name, Reference, Maybe (DeclOrBuiltin v a))
type UpdateTermDisplay v a = (Maybe [SimpleTermDisplay v a], [TermDisplay v a])
type UpdateTypeDisplay v a = (Maybe [SimpleTypeDisplay v a], [TypeDisplay v a])
type MetadataDisplay v a = (HQ.HashQualified, Referent, Maybe (Type v a))
type RenameTermDisplay v a = (Referent, Maybe (Type v a), Set HashQualified, Set HashQualified)
type RenameTypeDisplay v a = (Reference, Maybe (DeclOrBuiltin v a), Set HashQualified, Set HashQualified)
type MetadataDisplay v a = (HQ.HashQualified Name, Referent, Maybe (Type v a))
type RenameTermDisplay v a = (Referent, Maybe (Type v a), Set (HashQualified Name), Set (HashQualified Name))
type RenameTypeDisplay v a = (Reference, Maybe (DeclOrBuiltin v a), Set (HashQualified Name), Set (HashQualified Name))
type PatchDisplay = (Name, P.PatchDiff)
toOutput :: forall m v a
@ -246,7 +246,7 @@ toOutput typeOf declOrBuiltin hqLen names1 names2 ppe
| n <- toList ns ]
]
for typeAdds $ \(r, nsmd) -> do
hqmds :: [(HashQualified, [MetadataDisplay v a])] <-
hqmds :: [(HashQualified Name, [MetadataDisplay v a])] <-
for nsmd $ \(n, mdRefs) ->
(,) <$> pure (Names2.hqTypeName hqLen names2 n r)
<*> fillMetadata ppe mdRefs

10
parser-typechecker/src/Unison/Codebase/Editor/TodoOutput.hs
View File

@ -12,7 +12,7 @@ import qualified Unison.DataDeclaration as DD
import Unison.Reference (Reference)
import Unison.Names3 (Names0)
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Editor.DisplayThing (DisplayThing(RegularThing))
import Unison.Codebase.Editor.DisplayObject (DisplayObject(UserObject))
import Unison.Type (Type)
import Unison.DataDeclaration (Decl)
import qualified Unison.LabeledDependency as LD
@ -24,10 +24,10 @@ data TodoOutput v a = TodoOutput
{ todoScore :: Score
, todoFrontier ::
( [(Reference, Maybe (Type v a))]
, [(Reference, DisplayThing (Decl v a))])
, [(Reference, DisplayObject (Decl v a))])
, todoFrontierDependents ::
( [(Score, Reference, Maybe (Type v a))]
, [(Score, Reference, DisplayThing (Decl v a))])
, [(Score, Reference, DisplayObject (Decl v a))])
, nameConflicts :: Names0
, editConflicts :: Patch
} deriving (Show)
@ -45,9 +45,9 @@ labeledDependencies TodoOutput{..} = Set.fromList (
[LD.typeRef r | (_, _, Just t) <- fst todoFrontierDependents
, r <- toList (Type.dependencies t)] <>
-- and decls of type refs
[LD.typeRef r | (_, RegularThing d) <- snd todoFrontier
[LD.typeRef r | (_, UserObject d) <- snd todoFrontier
, r <- toList (DD.declDependencies d)] <>
[LD.typeRef r | (_, _, RegularThing d) <- snd todoFrontierDependents
[LD.typeRef r | (_, _, UserObject d) <- snd todoFrontierDependents
, r <- toList (DD.declDependencies d)]) <>
-- name conflicts
Set.map LD.referent (R.ran (Names.terms0 nameConflicts)) <>

5
parser-typechecker/src/Unison/Codebase/Execute.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
@ -37,7 +36,7 @@ execute codebase runtime mainName =
root <- Codebase.getRootBranch codebase >>= \case
Right r -> pure r
Left Codebase.NoRootBranch ->
die ("Couldn't identify a root namespace.")
die "Couldn't identify a root namespace."
Left (Codebase.CouldntLoadRootBranch h) ->
die ("Couldn't load root branch " ++ show h)
Left (Codebase.CouldntParseRootBranch h) ->
@ -49,7 +48,7 @@ execute codebase runtime mainName =
case mt of
MainTerm.NotAFunctionName s -> die ("Not a function name: " ++ s)
MainTerm.NotFound s -> die ("Not found: " ++ s)
MainTerm.BadType s -> die (s ++ " is not of type '{IO} ()")
MainTerm.BadType s _ -> die (s ++ " is not of type '{IO} ()")
MainTerm.Success _ tm _ -> do
let codeLookup = Codebase.toCodeLookup codebase
ppe = PPE.PrettyPrintEnv (const Nothing) (const Nothing)

17
parser-typechecker/src/Unison/Codebase/MainTerm.hs
View File

@ -17,6 +17,7 @@ import Unison.Var ( Var )
import qualified Unison.Builtin.Decls as DD
import qualified Unison.HashQualified as HQ
import qualified Unison.Referent as Referent
import Unison.Name ( Name )
import qualified Unison.Names3 as Names3
import Unison.Reference ( Reference )
import qualified Unison.Type as Type
@ -27,8 +28,8 @@ import Unison.Runtime.IOSource ( ioReference )
data MainTerm v
= NotAFunctionName String
| NotFound String
| BadType String
| Success HQ.HashQualified (Term v Ann) (Type v Ann)
| BadType String (Maybe (Type v Ann))
| Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann)
getMainTerm
:: (Monad m, Var v)
@ -49,10 +50,12 @@ getMainTerm loadTypeOfTerm parseNames0 mainName mainType =
typ <- loadTypeOfTerm ref
traceShowM typ
case typ of
Just typ | Typechecker.isSubtype mainType typ -> do
let tm = DD.forceTerm a a (Term.ref a ref)
return (Success hq tm typ)
_ -> pure (BadType mainName)
Just typ ->
if Typechecker.isSubtype mainType typ then do
let tm = DD.forceTerm a a (Term.ref a ref)
return (Success hq tm typ)
else pure (BadType mainName $ Just typ)
_ -> pure (BadType mainName Nothing)
_ -> pure (NotFound mainName)
-- forall a. '{IO} a
@ -72,7 +75,7 @@ builtinMain a =
-- [Result]
resultArr :: Ord v => a -> Type.Type v a
resultArr a = Type.app a (Type.ref a Type.vectorRef) (Type.ref a DD.testResultRef)
resultArr a = Type.app a (Type.ref a Type.listRef) (Type.ref a DD.testResultRef)
-- {IO} [Result]
ioResultArr :: Ord v => a -> Type.Type v a

3
parser-typechecker/src/Unison/Codebase/Metadata.hs
View File

@ -32,6 +32,9 @@ starToR4 = R4.fromList . fmap (\(r,n,_,(t,v)) -> (r,n,t,v)) . Star3.toList
hasMetadata :: Ord a => a -> Type -> Value -> Star a n -> Bool
hasMetadata a t v = Set.member (t, v) . R.lookupDom a . Star3.d3
hasMetadataWithType :: Ord a => a -> Type -> Star a n -> Bool
hasMetadataWithType a t = any (\(t', _) -> t' == t) . R.lookupDom a . Star3.d3
inserts :: (Ord a, Ord n) => [(a, Type, Value)] -> Star a n -> Star a n
inserts tups s = foldl' (flip insert) s tups

40
parser-typechecker/src/Unison/Codebase/Path.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
@ -26,7 +27,7 @@ import Unison.NameSegment ( NameSegment(NameSegment))
import qualified Unison.NameSegment as NameSegment
-- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"]
newtype Path = Path { toSeq :: Seq NameSegment } deriving (Eq, Ord)
newtype Path = Path { toSeq :: Seq NameSegment } deriving (Eq, Ord, Semigroup, Monoid)
newtype Absolute = Absolute { unabsolute :: Path } deriving (Eq,Ord)
newtype Relative = Relative { unrelative :: Path } deriving (Eq,Ord)
@ -48,6 +49,8 @@ isRoot = Seq.null . toSeq . unabsolute
absoluteToPath' :: Absolute -> Path'
absoluteToPath' abs = Path' (Left abs)
instance Show Path' where
show (Path' (Left abs)) = show abs
show (Path' (Right rel)) = show rel
@ -65,10 +68,10 @@ unsplit' (Path' (Right (Relative p)), seg) = Path' (Right (Relative (unsplit (p,
unsplit :: Split -> Path
unsplit (Path p, a) = Path (p :|> a)
unsplitHQ :: HQSplit -> HQ'.HashQualified' Path
unsplitHQ :: HQSplit -> HQ'.HashQualified Path
unsplitHQ (p, a) = fmap (snoc p) a
unsplitHQ' :: HQSplit' -> HQ'.HashQualified' Path'
unsplitHQ' :: HQSplit' -> HQ'.HashQualified Path'
unsplitHQ' (p, a) = fmap (snoc' p) a
type Split = (Path, NameSegment)
@ -100,14 +103,13 @@ prefix (Absolute (Path prefix)) (Path' p) = case p of
-- Left is some parse error tbd
parsePath' :: String -> Either String Path'
parsePath' p = case parsePathImpl' p of
Left e -> Left e
Right (p, "") -> Right p
Right (p, rem) ->
case (first show . (Lexer.wordyId0 <> Lexer.symbolyId0) <> unit') rem of
Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg))
Right (_, rem) ->
Left ("extra characters after " <> show p <> ": " <> show rem)
Left e -> Left e
Left e -> Left e
Right (p, "" ) -> Right p
Right (p, rem) -> case parseSegment rem of
Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg))
Right (_, rem) ->
Left ("extra characters after " <> show p <> ": " <> show rem)
Left e -> Left e
-- implementation detail of parsePath' and parseSplit'
-- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34")
@ -131,7 +133,15 @@ parsePathImpl' p = case p of
Right (segs, rem) ->
Left $ "extra characters after " <> segs <> ": " <> show rem
Left e -> Left e
segs p = go (first show . (Lexer.symbolyId <> Lexer.wordyId) <> unit') p
segs p = go parseSegment p
parseSegment :: String -> Either String (String, String)
parseSegment s =
first show
. (Lexer.wordyId <> Lexer.symbolyId)
<> unit'
<> const (Left ("I expected an identifier but found " <> s))
$ s
wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment
wordyNameSegment s = case Lexer.wordyId0 s of
@ -251,6 +261,12 @@ toPath' = \case
Path (NameSegment "" :<| tail) -> Path' . Left . Absolute . Path $ tail
p -> Path' . Right . Relative $ p
-- Forget whether the path is absolute or relative
fromPath' :: Path' -> Path
fromPath' (Path' e) = case e of
Left (Absolute p) -> p
Right (Relative p) -> p
toList :: Path -> [NameSegment]
toList = Foldable.toList . toSeq

4
parser-typechecker/src/Unison/Codebase/Serialization/V1.hs
View File

@ -512,7 +512,7 @@ putTerm putVar putA = putABT putVar putA go where
-> putWord8 9 *> putChild f *> putChild arg
Term.Ann e t
-> putWord8 10 *> putChild e *> putType putVar putA t
Term.Sequence vs
Term.List vs
-> putWord8 11 *> putFoldable putChild vs
Term.If cond t f
-> putWord8 12 *> putChild cond *> putChild t *> putChild f
@ -554,7 +554,7 @@ getTerm getVar getA = getABT getVar getA go where
8 -> Term.Handle <$> getChild <*> getChild
9 -> Term.App <$> getChild <*> getChild
10 -> Term.Ann <$> getChild <*> getType getVar getA
11 -> Term.Sequence . Sequence.fromList <$> getList getChild
11 -> Term.List . Sequence.fromList <$> getList getChild
12 -> Term.If <$> getChild <*> getChild <*> getChild
13 -> Term.And <$> getChild <*> getChild
14 -> Term.Or <$> getChild <*> getChild

12
parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs
View File

@ -1,15 +1,18 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
module Unison.Codebase.ShortBranchHash where
import Unison.Prelude
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Hash as Hash
import qualified Data.Text as Text
import qualified Data.Set as Set
import Data.Text (Text)
newtype ShortBranchHash =
ShortBranchHash { toText :: Text } -- base32hex characters
deriving (Eq, Ord)
deriving (Eq, Ord, Generic)
toString :: ShortBranchHash -> String
toString = Text.unpack . toText
@ -27,8 +30,9 @@ fullFromHash = ShortBranchHash . Hash.base32Hex . Causal.unRawHash
-- abc -> SBH abc
-- #abc -> SBH abc
fromText :: Text -> Maybe ShortBranchHash
fromText t | Text.all (`Set.member` Hash.validBase32HexChars) t =
Just . ShortBranchHash . Text.dropWhile (=='#') $ t
fromText (Text.dropWhile (=='#') -> t)
| Text.all (`Set.member` Hash.validBase32HexChars) t = Just
$ ShortBranchHash t
fromText _ = Nothing
instance Show ShortBranchHash where

4
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs
View File

@ -109,7 +109,7 @@ term1to2 h =
V1.Term.Handle b h -> V2.Term.Handle b h
V1.Term.App f a -> V2.Term.App f a
V1.Term.Ann e t -> V2.Term.Ann e (ttype1to2 t)
V1.Term.Sequence as -> V2.Term.Sequence as
V1.Term.List as -> V2.Term.List as
V1.Term.If c t f -> V2.Term.If c t f
V1.Term.And a b -> V2.Term.And a b
V1.Term.Or a b -> V2.Term.Or a b
@ -172,7 +172,7 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.Handle a a4 -> pure $ V1.Term.Handle a a4
V2.Term.App a a4 -> pure $ V1.Term.App a a4
V2.Term.Ann a t2 -> V1.Term.Ann a <$> ttype2to1 lookupSize t2
V2.Term.Sequence sa -> pure $ V1.Term.Sequence sa
V2.Term.List sa -> pure $ V1.Term.List sa
V2.Term.If a a4 a5 -> pure $ V1.Term.If a a4 a5
V2.Term.And a a4 -> pure $ V1.Term.And a a4
V2.Term.Or a a4 -> pure $ V1.Term.Or a a4

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

@ -103,7 +103,7 @@ serializeTerm x = do
putWord8 6
serializeBoolean b
incPosition
Sequence v -> do
List v -> do
elementPositions <- traverse serializeTerm v
putTag
putWord8 7

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

@ -28,7 +28,7 @@ import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Causal ( Causal )
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Editor.Input (Event(..), Input(..))
import qualified Unison.Codebase.SearchResult as SR
import qualified Unison.Server.SearchResult as SR
import qualified Unison.Codebase.Watch as Watch
import Unison.CommandLine.InputPattern (InputPattern (parse))
import qualified Unison.HashQualified' as HQ

9
parser-typechecker/src/Unison/CommandLine/InputPatterns.hs
View File

@ -34,6 +34,7 @@ import qualified Unison.CommandLine.InputPattern as I
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
import qualified Unison.Name as Name
import Unison.Name ( Name )
import qualified Unison.Names2 as Names
import qualified Unison.Util.ColorText as CT
import qualified Unison.Util.Pretty as P
@ -497,7 +498,7 @@ deleteTypeReplacement :: InputPattern
deleteTypeReplacement = deleteReplacement False
parseHashQualifiedName
:: String -> Either (P.Pretty CT.ColorText) HQ.HashQualified
:: String -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name)
parseHashQualifiedName s =
maybe
( Left
@ -969,7 +970,11 @@ previewMergeLocal = InputPattern
)
replaceEdit
:: (HQ.HashQualified -> HQ.HashQualified -> Maybe Input.PatchPath -> Input)
:: ( HQ.HashQualified Name
-> HQ.HashQualified Name
-> Maybe Input.PatchPath
-> Input
)
-> String
-> InputPattern
replaceEdit f s = self

29
parser-typechecker/src/Unison/CommandLine/Main.hs
View File

@ -74,23 +74,23 @@ getUserInput
-> Path.Absolute
-> [String]
-> m Input
getUserInput patterns codebase branch currentPath numberedArgs =
Line.runInputT settings go
getUserInput patterns codebase branch currentPath numberedArgs = Line.runInputT
settings
go
where
go = do
line <- Line.getInputLine $
P.toANSI 80 ((P.green . P.shown) currentPath <> fromString prompt)
line <- Line.getInputLine
$ P.toANSI 80 ((P.green . P.shown) currentPath <> fromString prompt)
case line of
Nothing -> pure QuitI
Just l ->
case words l of
[] -> go
ws ->
case parseInput patterns . (>>= expandNumber numberedArgs) $ ws of
Left msg -> do
liftIO $ putPrettyLn msg
go
Right i -> pure i
Just l -> case words l of
[] -> go
ws ->
case parseInput patterns . (>>= expandNumber numberedArgs) $ ws of
Left msg -> do
liftIO $ putPrettyLn msg
go
Right i -> pure i
settings = Line.Settings tabComplete (Just ".unisonHistory") True
tabComplete = Line.completeWordWithPrev Nothing " " $ \prev word ->
-- User hasn't finished a command name, complete from command names
@ -227,7 +227,7 @@ main dir defaultBaseLib initialPath (config,cancelConfig) initialInputs startRun
writeIORef pageOutput True
pure x) `catch` interruptHandler
interruptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput
interruptHandler _ = pure $ Right QuitI
interruptHandler e = error (show e)
cleanup = do
Runtime.terminate runtime
cancelConfig
@ -236,7 +236,6 @@ main dir defaultBaseLib initialPath (config,cancelConfig) initialInputs startRun
loop state = do
writeIORef pathRef (view HandleInput.currentPath state)
let free = runStateT (runMaybeT HandleInput.loop) state
(o, state') <- HandleCommand.commandLine config awaitInput
(writeIORef rootRef)
runtime

191
parser-typechecker/src/Unison/CommandLine/OutputMessages.hs
View File

@ -11,13 +11,14 @@ module Unison.CommandLine.OutputMessages where
import Unison.Prelude hiding (unlessM)
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Editor.Output
import qualified Unison.Codebase.Editor.Output as E
import qualified Unison.Codebase.Editor.Output as Output
import qualified Unison.Codebase.Editor.TodoOutput as TO
import qualified Unison.Codebase.Editor.SearchResult' as SR'
import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD
import qualified Unison.Server.SearchResult' as SR'
import Unison.Server.Backend (ShallowListEntry(..))
import Control.Lens
import qualified Control.Monad.State.Strict as State
@ -99,7 +100,7 @@ import qualified Unison.Util.Relation as R
import Unison.Var (Var)
import qualified Unison.Var as Var
import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult
import Unison.Codebase.Editor.DisplayThing (DisplayThing(MissingThing, BuiltinThing, RegularThing))
import Unison.Codebase.Editor.DisplayObject (DisplayObject(MissingObject, BuiltinObject, UserObject))
import qualified Unison.Codebase.Editor.Input as Input
import qualified Unison.Hash as Hash
import qualified Unison.Codebase.Causal as Causal
@ -249,7 +250,23 @@ prettyRemoteNamespace =
notifyUser :: forall v . Var v => FilePath -> Output v -> IO Pretty
notifyUser dir o = case o of
Success -> pure $ P.bold "Done."
Success -> pure $ P.bold "Done."
BadRootBranch e -> case e of
Codebase.NoRootBranch ->
pure . P.fatalCallout $ "I couldn't find the codebase root!"
Codebase.CouldntParseRootBranch s ->
pure
. P.warnCallout
$ "I coulnd't parse a valid namespace from "
<> P.string (show s)
<> "."
Codebase.CouldntLoadRootBranch h ->
pure
. P.warnCallout
$ "I couldn't find a root namespace with the hash "
<> prettySBH (SBH.fullFromHash h)
<> "."
WarnIncomingRootBranch current hashes -> pure $
if null hashes then P.wrap $
"Please let someone know I generated an empty IncomingRootBranch"
@ -347,6 +364,15 @@ notifyUser dir o = case o of
else putPretty' " 🚫 "
pure mempty
TermMissingType ref ->
pure . P.fatalCallout . P.lines $ [
P.wrap $ "The type signature for reference "
<> P.blue (P.text (Reference.toText ref))
<> " is missing from the codebase! This means something might be wrong "
<> " with the codebase, or the term was deleted just now "
<> " by someone else. Trying your command again might fix it."
]
MetadataMissingType ppe ref -> pure . P.fatalCallout . P.lines $ [
P.wrap $ "The metadata value " <> P.red (prettyTermName ppe ref)
<> "is missing a type signature in the codebase.",
@ -410,6 +436,15 @@ notifyUser dir o = case o of
"",
P.indentN 2 $ P.lines [ P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts ]
]
BadMainFunction main ty ppe ts -> pure . P.callout "😶" $ P.lines [
P.string "I found this function:",
"",
P.indentN 2 $ P.string main <> " : " <> TypePrinter.pretty ppe ty,
"",
P.wrap $ P.string "but in order for me to" <> P.backticked (P.string "run") <> "it it needs to have the type:",
"",
P.indentN 2 $ P.lines [ P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts ]
]
NoUnisonFile -> do
dir' <- canonicalizePath dir
fileName <- renderFileName dir'
@ -494,10 +529,10 @@ notifyUser dir o = case o of
--
-- Term (with hash #asldfkjsdlfkjsdf): .util.frobnicate, foo, blarg.mcgee
-- Types (with hash #hsdflkjsdfsldkfj): Optional, Maybe, foo
ListShallow ppe entries -> pure $
ListShallow ppe entries ->
-- todo: make a version of prettyNumberedResult to support 3-columns
if null entries then P.lit "nothing to show"
else numberedEntries entries
pure $ if null entries then P.lit "nothing to show"
else numberedEntries entries
where
numberedEntries :: [ShallowListEntry v a] -> P.Pretty P.ColorText
numberedEntries entries =
@ -506,16 +541,16 @@ notifyUser dir o = case o of
f (i, (p1, p2)) = (P.hiBlack . fromString $ show i <> ".", p1, p2)
formatEntry :: ShallowListEntry v a -> (P.Pretty P.ColorText, P.Pretty P.ColorText)
formatEntry = \case
ShallowTermEntry _r hq ot ->
ShallowTermEntry _r hq ot _ ->
(P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment $ hq
, P.lit "(" <> maybe "type missing" (TypePrinter.pretty ppe) ot <> P.lit ")" )
ShallowTypeEntry r hq ->
ShallowTypeEntry r hq _ ->
(P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment $ hq
,isBuiltin r)
ShallowBranchEntry ns count ->
ShallowBranchEntry ns _ count ->
((P.syntaxToColor . prettyName . Name.fromSegment) ns <> "/"
,case count of
1 -> P.lit ("(1 definition)")
1 -> P.lit "(1 definition)"
_n -> P.lit "(" <> P.shown count <> P.lit " definitions)")
ShallowPatchEntry ns ->
((P.syntaxToColor . prettyName . Name.fromSegment) ns
@ -523,7 +558,6 @@ notifyUser dir o = case o of
isBuiltin = \case
Reference.Builtin{} -> P.lit "(builtin type)"
Reference.DerivedId{} -> P.lit "(type)"
SlurpOutput input ppe s -> let
isPast = case input of Input.AddI{} -> True
Input.UpdateI{} -> True
@ -1077,7 +1111,7 @@ prettySBH :: IsString s => ShortBranchHash -> P.Pretty s
prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash)
formatMissingStuff :: (Show tm, Show typ) =>
[(HQ.HashQualified, tm)] -> [(HQ.HashQualified, typ)] -> Pretty
[(HQ.HashQualified Name, tm)] -> [(HQ.HashQualified Name, typ)] -> Pretty
formatMissingStuff terms types =
(unlessM (null terms) . P.fatalCallout $
P.wrap "The following terms have a missing or corrupted type signature:"
@ -1090,8 +1124,8 @@ formatMissingStuff terms types =
displayDefinitions' :: Var v => Ord a1
=> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayThing (DD.Decl v a1))
-> Map Reference.Reference (DisplayThing (Term v a1))
-> Map Reference.Reference (DisplayObject (DD.Decl v a1))
-> Map Reference.Reference (DisplayObject (Term v a1))
-> Pretty
displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms)
where
@ -1104,14 +1138,14 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp
$ Map.mapKeys (first (PPE.typeName ppeDecl) . dupe) types
go ((n, r), dt) =
case dt of
MissingThing r -> missing n r
BuiltinThing -> builtin n
RegularThing tm -> TermPrinter.prettyBinding (ppeBody r) n tm
MissingObject r -> missing n r
BuiltinObject -> builtin n
UserObject tm -> TermPrinter.prettyBinding (ppeBody r) n tm
go2 ((n, r), dt) =
case dt of
MissingThing r -> missing n r
BuiltinThing -> builtin n
RegularThing decl -> case decl of
MissingObject r -> missing n r
BuiltinObject -> builtin n
UserObject decl -> case decl of
Left d -> DeclPrinter.prettyEffectDecl (ppeBody r) r n d
Right d -> DeclPrinter.prettyDataDecl (ppeBody r) r n d
builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in."
@ -1148,8 +1182,8 @@ displayRendered outputLoc pp =
displayDefinitions :: Var v => Ord a1 =>
Maybe FilePath
-> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayThing (DD.Decl v a1))
-> Map Reference.Reference (DisplayThing (Term v a1))
-> Map Reference.Reference (DisplayObject (DD.Decl v a1))
-> Map Reference.Reference (DisplayObject (Term v a1))
-> IO Pretty
displayDefinitions _outputLoc _ppe types terms | Map.null types && Map.null terms =
pure $ P.callout "😶" "No results to display."
@ -1256,17 +1290,17 @@ prettyTypeResultHeaderFull' (SR'.TypeResult' (HQ'.toHQ -> name) dt r (Set.map HQ
where greyHash = styleHashQualified' id P.hiBlack
prettyDeclTriple :: Var v =>
(HQ.HashQualified, Reference.Reference, DisplayThing (DD.Decl v a))
(HQ.HashQualified Name, Reference.Reference, DisplayObject (DD.Decl v a))
-> Pretty
prettyDeclTriple (name, _, displayDecl) = case displayDecl of
BuiltinThing -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
MissingThing _ -> mempty -- these need to be handled elsewhere
RegularThing decl -> case decl of
BuiltinObject -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
MissingObject _ -> mempty -- these need to be handled elsewhere
UserObject decl -> case decl of
Left ed -> P.syntaxToColor $ DeclPrinter.prettyEffectHeader name ed
Right dd -> P.syntaxToColor $ DeclPrinter.prettyDataHeader name dd
prettyDeclPair :: Var v =>
PPE.PrettyPrintEnv -> (Reference, DisplayThing (DD.Decl v a))
PPE.PrettyPrintEnv -> (Reference, DisplayObject (DD.Decl v a))
-> Pretty
prettyDeclPair ppe (r, dt) = prettyDeclTriple (PPE.typeName ppe r, r, dt)
@ -1334,7 +1368,7 @@ todoOutput ppe todo =
corruptTerms =
[ (PPE.termName ppeu (Referent.Ref r), r) | (r, Nothing) <- frontierTerms ]
corruptTypes =
[ (PPE.typeName ppeu r, r) | (r, MissingThing _) <- frontierTypes ]
[ (PPE.typeName ppeu r, r) | (r, MissingObject _) <- frontierTypes ]
goodTerms ts =
[ (PPE.termName ppeu (Referent.Ref r), typ) | (r, Just typ) <- ts ]
todoConflicts = if TO.noConflicts todo then mempty else P.lines . P.nonEmpty $
@ -1397,7 +1431,7 @@ listOfDefinitions ppe detailed results =
pure $ listOfDefinitions' ppe detailed results
listOfLinks ::
Var v => PPE.PrettyPrintEnv -> [(HQ.HashQualified, Maybe (Type v a))] -> IO Pretty
Var v => PPE.PrettyPrintEnv -> [(HQ.HashQualified Name, Maybe (Type v a))] -> IO Pretty
listOfLinks _ [] = pure . P.callout "😶" . P.wrap $
"No results. Try using the " <>
IP.makeExample IP.link [] <>
@ -1526,7 +1560,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput{..} =
leftNamePad :: Int = foldl1' max $
map (foldl1' max . map HQ'.nameLength . toList . view _3) terms <>
map (foldl1' max . map HQ'.nameLength . toList . view _3) types
prettyGroup :: ((Referent, b, Set HQ'.HashQualified, Set HQ'.HashQualified), Int)
prettyGroup :: ((Referent, b, Set (HQ'.HashQualified Name), Set (HQ'.HashQualified Name)), Int)
-> Numbered Pretty
prettyGroup ((r, _, olds, news),i) = let
-- [ "peach ┐"
@ -1612,7 +1646,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput{..} =
let (nums, decls) = unzip pairs
let boxLeft = case hqmds of _:_:_ -> P.boxLeft; _ -> id
pure . P.column2 $ zip nums (boxLeft decls)
prettyLine :: Reference -> Maybe (DD.DeclOrBuiltin v a) -> (HQ'.HashQualified, [OBD.MetadataDisplay v a]) -> Numbered (Pretty, Pretty)
prettyLine :: Reference -> Maybe (DD.DeclOrBuiltin v a) -> (HQ'.HashQualified Name, [OBD.MetadataDisplay v a]) -> Numbered (Pretty, Pretty)
prettyLine r odecl (hq, mds) = do
n <- numHQ' newPath hq (Referent.Ref r)
pure . (n,) $ prettyDecl hq odecl <> case length mds of
@ -1748,12 +1782,12 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput{..} =
numPatch prefix name =
addNumberedArg . Name.toString . Name.makeAbsolute $ Path.prefixName prefix name
numHQ :: Path.Absolute -> HQ.HashQualified -> Referent -> Numbered Pretty
numHQ :: Path.Absolute -> HQ.HashQualified Name -> Referent -> Numbered Pretty
numHQ prefix hq r = addNumberedArg (HQ.toString hq')
where
hq' = HQ.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
numHQ' :: Path.Absolute -> HQ'.HashQualified -> Referent -> Numbered Pretty
numHQ' :: Path.Absolute -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
numHQ' prefix hq r = addNumberedArg (HQ'.toString hq')
where
hq' = HQ'.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
@ -1776,49 +1810,60 @@ noResults = P.callout "😶" $
P.wrap $ "No results. Check your spelling, or try using tab completion "
<> "to supply command arguments."
listOfDefinitions' :: Var v
=> PPE.PrettyPrintEnv -- for printing types of terms :-\
-> E.ListDetailed
-> [SR'.SearchResult' v a]
-> Pretty
listOfDefinitions' ppe detailed results =
if null results then noResults
else P.lines . P.nonEmpty $ prettyNumberedResults :
[formatMissingStuff termsWithMissingTypes missingTypes
,unlessM (null missingBuiltins) . bigproblem $ P.wrap
"I encountered an inconsistency in the codebase; these definitions refer to built-ins that this version of unison doesn't know about:" `P.hang`
P.column2 ( (P.bold "Name", P.bold "Built-in")
-- : ("-", "-")
: fmap (bimap (P.syntaxToColor . prettyHashQualified)
(P.text . Referent.toText)) missingBuiltins)
]
where
listOfDefinitions'
:: Var v
=> PPE.PrettyPrintEnv -- for printing types of terms :-\
-> E.ListDetailed
-> [SR'.SearchResult' v a]
-> Pretty
listOfDefinitions' ppe detailed results = if null results
then noResults
else
P.lines
. P.nonEmpty
$ prettyNumberedResults
: [ formatMissingStuff termsWithMissingTypes missingTypes
, unlessM (null missingBuiltins)
. bigproblem
$ P.wrap
"I encountered an inconsistency in the codebase; these definitions refer to built-ins that this version of unison doesn't know about:"
`P.hang` P.column2
( (P.bold "Name", P.bold "Built-in")
-- : ("-", "-")
: fmap
(bimap (P.syntaxToColor . prettyHashQualified)
(P.text . Referent.toText)
)
missingBuiltins
)
]
where
prettyNumberedResults = P.numberedList prettyResults
-- todo: group this by namespace
prettyResults =
map (SR'.foldResult' renderTerm renderType)
(filter (not.missingType) results)
where
(renderTerm, renderType) =
if detailed then
(unsafePrettyTermResultSigFull' ppe, prettyTypeResultHeaderFull')
else
(unsafePrettyTermResultSig' ppe, prettyTypeResultHeader')
missingType (SR'.Tm _ Nothing _ _) = True
missingType (SR'.Tp _ (MissingThing _) _ _) = True
missingType _ = False
prettyResults = map (SR'.foldResult' renderTerm renderType)
(filter (not . missingType) results)
where
(renderTerm, renderType) = if detailed
then (unsafePrettyTermResultSigFull' ppe, prettyTypeResultHeaderFull')
else (unsafePrettyTermResultSig' ppe, prettyTypeResultHeader')
missingType (SR'.Tm _ Nothing _ _) = True
missingType (SR'.Tp _ (MissingObject _) _ _) = True
missingType _ = False
-- termsWithTypes = [(name,t) | (name, Just t) <- sigs0 ]
-- where sigs0 = (\(name, _, typ) -> (name, typ)) <$> terms
termsWithMissingTypes =
[ (HQ'.toHQ name, r)
| SR'.Tm name Nothing (Referent.Ref (Reference.DerivedId r)) _ <- results ]
missingTypes = nubOrdOn snd $
[ (HQ'.toHQ name, Reference.DerivedId r)
| SR'.Tp name (MissingThing r) _ _ <- results ] <>
[ (HQ'.toHQ name, r)
| SR'.Tm name Nothing (Referent.toTypeReference -> Just r) _ <- results]
[ (HQ'.toHQ name, Reference.idToShortHash r)
| SR'.Tm name Nothing (Referent.Ref (Reference.DerivedId r)) _ <- results
]
missingTypes =
nubOrdOn snd
$ [ (HQ'.toHQ name, r) | SR'.Tp name (MissingObject r) _ _ <- results ]
<> [ (HQ'.toHQ name, Reference.toShortHash r)
| SR'.Tm name Nothing (Referent.toTypeReference -> Just r) _ <- results
]
missingBuiltins = results >>= \case
SR'.Tm name Nothing r@(Referent.Ref (Reference.Builtin _)) _ -> [(HQ'.toHQ name,r)]
SR'.Tm name Nothing r@(Referent.Ref (Reference.Builtin _)) _ ->
[(HQ'.toHQ name, r)]
_ -> []
watchPrinter
@ -1857,7 +1902,7 @@ watchPrinter src ppe ann kind term isHit =
P.lines
[ fromString (show lineNum) <> " | " <> P.text line
, case (kind, term) of
(UF.TestWatch, Term.Sequence' tests) -> foldMap renderTest tests
(UF.TestWatch, Term.List' tests) -> foldMap renderTest tests
_ -> P.lines
[ fromString (replicate lineNumWidth ' ')
<> fromString extra
@ -1975,7 +2020,7 @@ prettyRepoBranch (RemoteRepo.GitRepo url treeish) =
isTestOk :: Term v Ann -> Bool
isTestOk tm = case tm of
Term.Sequence' ts -> all isSuccess ts where
Term.List' ts -> all isSuccess ts where
isSuccess (Term.App' (Term.Constructor' ref cid) _) =
cid == DD.okConstructorId &&
ref == DD.testResultRef

65
parser-typechecker/src/Unison/DeclPrinter.hs
View File

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.DeclPrinter where
@ -15,6 +16,7 @@ import qualified Unison.ConstructorType as CT
import Unison.HashQualified ( HashQualified )
import qualified Unison.HashQualified as HQ
import qualified Unison.Name as Name
import Unison.Name ( Name )
import Unison.NamePrinter ( styleHashQualified'' )
import Unison.PrettyPrintEnv ( PrettyPrintEnv )
import qualified Unison.PrettyPrintEnv as PPE
@ -34,7 +36,7 @@ prettyDecl
:: Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified
-> HashQualified Name
-> DD.Decl v a
-> Pretty SyntaxText
prettyDecl ppe r hq d = case d of
@ -45,7 +47,7 @@ prettyEffectDecl
:: Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified
-> HashQualified Name
-> EffectDeclaration v a
-> Pretty SyntaxText
prettyEffectDecl ppe r name = prettyGADT ppe r name . toDataDecl
@ -54,7 +56,7 @@ prettyGADT
:: Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified
-> HashQualified Name
-> DataDeclaration v a
-> Pretty SyntaxText
prettyGADT env r name dd = P.hang header . P.lines $ constructor <$> zip
@ -68,8 +70,13 @@ prettyGADT env r name dd = P.hang header . P.lines $ constructor <$> zip
header = prettyEffectHeader name (DD.EffectDeclaration dd) <> (fmt S.ControlKeyword " where")
prettyPattern
:: PrettyPrintEnv -> Reference -> HashQualified -> Int -> Pretty SyntaxText
prettyPattern env r namespace n = styleHashQualified'' (fmt S.Constructor)
:: PrettyPrintEnv
-> Reference
-> HashQualified Name
-> Int
-> Pretty SyntaxText
prettyPattern env r namespace n = styleHashQualified''
(fmt S.Constructor)
( HQ.stripNamespace (fromMaybe "" $ Name.toText <$> HQ.toName namespace)
$ PPE.patternName env r n
)
@ -78,7 +85,7 @@ prettyDataDecl
:: Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified
-> HashQualified Name
-> DataDeclaration v a
-> Pretty SyntaxText
prettyDataDecl env r name dd =
@ -118,9 +125,9 @@ fieldNames
:: forall v a . Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified
-> HashQualified Name
-> DataDeclaration v a
-> Maybe [HashQualified]
-> Maybe [HashQualified Name]
fieldNames env r name dd = case DD.constructors dd of
[(_, typ)] -> let
vars :: [v]
@ -150,24 +157,34 @@ prettyModifier DD.Structural = mempty
prettyModifier (DD.Unique _uid) =
fmt S.DataTypeModifier "unique" -- <> ("[" <> P.text uid <> "] ")
prettyDataHeader :: Var v => HashQualified -> DD.DataDeclaration v a -> Pretty SyntaxText
prettyDataHeader name dd =
P.sepNonEmpty " " [
prettyModifier (DD.modifier dd),
fmt S.DataTypeKeyword "type",
styleHashQualified'' (fmt $ S.HashQualifier name) name,
P.sep " " (fmt S.DataTypeParams . P.text . Var.name <$> DD.bound dd) ]
prettyDataHeader
:: Var v => HashQualified Name -> DD.DataDeclaration v a -> Pretty SyntaxText
prettyDataHeader name dd = P.sepNonEmpty
" "
[ prettyModifier (DD.modifier dd)
, fmt S.DataTypeKeyword "type"
, styleHashQualified'' (fmt $ S.HashQualifier name) name
, P.sep " " (fmt S.DataTypeParams . P.text . Var.name <$> DD.bound dd)
]
prettyEffectHeader :: Var v => HashQualified -> DD.EffectDeclaration v a -> Pretty SyntaxText
prettyEffectHeader name ed = P.sepNonEmpty " " [
prettyModifier (DD.modifier (DD.toDataDecl ed)),
fmt S.DataTypeKeyword "ability",
styleHashQualified'' (fmt $ S.HashQualifier name) name,
P.sep " " (fmt S.DataTypeParams . P.text . Var.name <$> DD.bound (DD.toDataDecl ed)) ]
prettyEffectHeader
:: Var v
=> HashQualified Name
-> DD.EffectDeclaration v a
-> Pretty SyntaxText
prettyEffectHeader name ed = P.sepNonEmpty
" "
[ prettyModifier (DD.modifier (DD.toDataDecl ed))
, fmt S.DataTypeKeyword "ability"
, styleHashQualified'' (fmt $ S.HashQualifier name) name
, P.sep
" "
(fmt S.DataTypeParams . P.text . Var.name <$> DD.bound (DD.toDataDecl ed))
]
prettyDeclHeader
:: Var v
=> HashQualified
=> HashQualified Name
-> Either (DD.EffectDeclaration v a) (DD.DataDeclaration v a)
-> Pretty SyntaxText
prettyDeclHeader name (Left e) = prettyEffectHeader name e
@ -175,7 +192,7 @@ prettyDeclHeader name (Right d) = prettyDataHeader name d
prettyDeclOrBuiltinHeader
:: Var v
=> HashQualified
=> HashQualified Name
-> DD.DeclOrBuiltin v a
-> Pretty SyntaxText
prettyDeclOrBuiltinHeader name (DD.Builtin ctype) = case ctype of
@ -183,5 +200,5 @@ prettyDeclOrBuiltinHeader name (DD.Builtin ctype) = case ctype of
CT.Effect -> fmt S.DataTypeKeyword "builtin ability " <> styleHashQualified'' (fmt $ S.HashQualifier name) name
prettyDeclOrBuiltinHeader name (DD.Decl e) = prettyDeclHeader name e
fmt :: S.Element -> Pretty S.SyntaxText -> Pretty S.SyntaxText
fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt = P.withSyntax

3
parser-typechecker/src/Unison/FileParser.hs
View File

@ -244,8 +244,7 @@ dataDeclaration mod = do
-- ctorType e.g. `a -> Optional a`
-- or just `Optional a` in the case of `None`
ctorType = foldr arrow ctorReturnType ctorArgs
ctorAnn = ann ctorName <>
(if null ctorArgs then mempty else ann (last ctorArgs))
ctorAnn = ann ctorName <> maybe (ann ctorName) ann (lastMay ctorArgs)
in (ann ctorName, Var.namespaced [L.payload name, L.payload ctorName],
Type.foralls ctorAnn typeArgVs ctorType)
prefixVar = TermParser.verifyRelativeVarName prefixDefinitionName

22
parser-typechecker/src/Unison/NamePrinter.hs
View File

@ -20,13 +20,13 @@ import qualified Unison.Util.Pretty as PP
prettyName :: IsString s => Name -> Pretty s
prettyName = PP.text . Name.toText
prettyHashQualified :: HQ.HashQualified -> Pretty SyntaxText
prettyHashQualified :: HQ.HashQualified Name -> Pretty SyntaxText
prettyHashQualified hq = styleHashQualified' id (fmt $ S.HashQualifier hq) hq
prettyHashQualified' :: HQ'.HashQualified -> Pretty SyntaxText
prettyHashQualified' :: HQ'.HashQualified Name -> Pretty SyntaxText
prettyHashQualified' = prettyHashQualified . HQ'.toHQ
prettyHashQualified0 :: IsString s => HQ.HashQualified -> Pretty s
prettyHashQualified0 :: IsString s => HQ.HashQualified Name -> Pretty s
prettyHashQualified0 = PP.text . HQ.toText
-- | Pretty-print a reference as a name and the given number of characters of
@ -58,13 +58,13 @@ prettyShortHash :: IsString s => ShortHash -> Pretty s
prettyShortHash = fromString . SH.toString
styleHashQualified ::
IsString s => (Pretty s -> Pretty s) -> HQ.HashQualified -> Pretty s
IsString s => (Pretty s -> Pretty s) -> HQ.HashQualified Name -> Pretty s
styleHashQualified style hq = styleHashQualified' style id hq
styleHashQualified' ::
IsString s => (Pretty s -> Pretty s)
-> (Pretty s -> Pretty s)
-> HQ.HashQualified
-> HQ.HashQualified Name
-> Pretty s
styleHashQualified' nameStyle hashStyle = \case
HQ.NameOnly n -> nameStyle (prettyName n)
@ -72,10 +72,12 @@ styleHashQualified' nameStyle hashStyle = \case
HQ.HashQualified n h ->
PP.group $ nameStyle (prettyName n) <> hashStyle (prettyShortHash h)
styleHashQualified'' :: (Pretty SyntaxText -> Pretty SyntaxText)
-> HQ.HashQualified
-> Pretty SyntaxText
styleHashQualified'' nameStyle hq = styleHashQualified' nameStyle (fmt $ S.HashQualifier hq) hq
styleHashQualified''
:: (Pretty SyntaxText -> Pretty SyntaxText)
-> HQ.HashQualified Name
-> Pretty SyntaxText
styleHashQualified'' nameStyle hq =
styleHashQualified' nameStyle (fmt $ S.HashQualifier hq) hq
fmt :: S.Element -> Pretty S.SyntaxText -> Pretty S.SyntaxText
fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt = PP.withSyntax

21
parser-typechecker/src/Unison/Parser.hs
View File

@ -89,12 +89,13 @@ data Error v
= SignatureNeedsAccompanyingBody (L.Token v)
| DisallowedAbsoluteName (L.Token Name)
| EmptyBlock (L.Token String)
| UnknownAbilityConstructor (L.Token HQ.HashQualified) (Set (Reference, Int))
| UnknownDataConstructor (L.Token HQ.HashQualified) (Set (Reference, Int))
| UnknownTerm (L.Token HQ.HashQualified) (Set Referent)
| UnknownType (L.Token HQ.HashQualified) (Set Reference)
| UnknownId (L.Token HQ.HashQualified) (Set Referent) (Set Reference)
| UnknownAbilityConstructor (L.Token (HQ.HashQualified Name)) (Set (Reference, Int))
| UnknownDataConstructor (L.Token (HQ.HashQualified Name)) (Set (Reference, Int))
| UnknownTerm (L.Token (HQ.HashQualified Name)) (Set Referent)
| UnknownType (L.Token (HQ.HashQualified Name)) (Set Reference)
| UnknownId (L.Token (HQ.HashQualified Name)) (Set Referent) (Set Reference)
| ExpectedBlockOpen String (L.Token L.Lexeme)
| EmptyMatch
| EmptyWatch
| UseInvalidPrefixSuffix (Either (L.Token Name) (L.Token Name)) (Maybe [L.Token Name])
| UseEmpty (L.Token String) -- an empty `use` statement
@ -155,7 +156,7 @@ instance P.Stream Input where
advance1 _ _ cp = setPos cp . L.end
advanceN _ _ cp = setPos cp . L.end . last . inputStream
advanceN _ _ cp = maybe cp (setPos cp . L.end) . lastMay . inputStream
take1_ (P.chunkToTokens proxy -> []) = Nothing
take1_ (P.chunkToTokens proxy -> t:ts) = Just (t, P.tokensToChunk proxy ts)
@ -335,12 +336,12 @@ symbolyDefinitionName = queryToken $ \case
parenthesize :: Ord v => P v a -> P v a
parenthesize p = P.try (openBlockWith "(" *> p) <* closeBlock
hqPrefixId, hqInfixId :: Ord v => P v (L.Token HQ.HashQualified)
hqPrefixId, hqInfixId :: Ord v => P v (L.Token (HQ.HashQualified Name))
hqPrefixId = hqWordyId_ <|> parenthesize hqSymbolyId_
hqInfixId = hqSymbolyId_ <|> hqBacktickedId_
-- Parse a hash-qualified alphanumeric identifier
hqWordyId_ :: Ord v => P v (L.Token HQ.HashQualified)
hqWordyId_ :: Ord v => P v (L.Token (HQ.HashQualified Name))
hqWordyId_ = queryToken $ \case
L.WordyId "" (Just h) -> Just $ HQ.HashOnly h
L.WordyId s (Just h) -> Just $ HQ.HashQualified (Name.fromString s) h
@ -350,14 +351,14 @@ hqWordyId_ = queryToken $ \case
_ -> Nothing
-- Parse a hash-qualified symboly ID like >>=#foo or &&
hqSymbolyId_ :: Ord v => P v (L.Token HQ.HashQualified)
hqSymbolyId_ :: Ord v => P v (L.Token (HQ.HashQualified Name))
hqSymbolyId_ = queryToken $ \case
L.SymbolyId "" (Just h) -> Just $ HQ.HashOnly h
L.SymbolyId s (Just h) -> Just $ HQ.HashQualified (Name.fromString s) h
L.SymbolyId s Nothing -> Just $ HQ.NameOnly (Name.fromString s)
_ -> Nothing
hqBacktickedId_ :: Ord v => P v (L.Token HQ.HashQualified)
hqBacktickedId_ :: Ord v => P v (L.Token (HQ.HashQualified Name))
hqBacktickedId_ = queryToken $ \case
L.Backticks "" (Just h) -> Just $ HQ.HashOnly h
L.Backticks s (Just h) -> Just $ HQ.HashQualified (Name.fromString s) h

33
parser-typechecker/src/Unison/PrettyPrintEnv.hs
View File

@ -22,11 +22,11 @@ import qualified Data.Set as Set
data PrettyPrintEnv = PrettyPrintEnv {
-- names for terms, constructors, and requests
terms :: Referent -> Maybe HashQualified,
terms :: Referent -> Maybe (HashQualified Name),
-- names for types
types :: Reference -> Maybe HashQualified }
types :: Reference -> Maybe (HashQualified Name) }
patterns :: PrettyPrintEnv -> Reference -> Int -> Maybe HashQualified
patterns :: PrettyPrintEnv -> Reference -> Int -> Maybe (HashQualified Name)
patterns ppe r cid = terms ppe (Referent.Con r cid CT.Data)
<|>terms ppe (Referent.Con r cid CT.Effect)
@ -82,32 +82,31 @@ unionLeft e1 e2 = PrettyPrintEnv
(\r -> terms e1 r <|> terms e2 r)
(\r -> types e1 r <|> types e2 r)
assignTermName :: Referent -> HashQualified -> PrettyPrintEnv -> PrettyPrintEnv
assignTermName r name = (fromTermNames [(r,name)] `unionLeft`)
assignTermName
:: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv
assignTermName r name = (fromTermNames [(r, name)] `unionLeft`)
fromTypeNames :: [(Reference,HashQualified)] -> PrettyPrintEnv
fromTypeNames types = let
m = Map.fromList types
in PrettyPrintEnv (const Nothing) (`Map.lookup` m)
fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv
fromTypeNames types =
let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m)
fromTermNames :: [(Referent,HashQualified)] -> PrettyPrintEnv
fromTermNames tms = let
m = Map.fromList tms
in PrettyPrintEnv (`Map.lookup` m) (const Nothing)
fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv
fromTermNames tms =
let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing)
-- todo: these need to be a dynamic length, but we need additional info
todoHashLength :: Int
todoHashLength = 10
termName :: PrettyPrintEnv -> Referent -> HashQualified
termName :: PrettyPrintEnv -> Referent -> HashQualified Name
termName env r =
fromMaybe (HQ.take todoHashLength $ HQ.fromReferent r) (terms env r)
typeName :: PrettyPrintEnv -> Reference -> HashQualified
typeName :: PrettyPrintEnv -> Reference -> HashQualified Name
typeName env r =
fromMaybe (HQ.take todoHashLength $ HQ.fromReference r) (types env r)
patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified
patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name
patternName env r cid =
case patterns env r cid of
Just name -> name
@ -131,7 +130,7 @@ type Prefix = [Text]
type Imports = Map Name Suffix
-- Give the shortened version of an FQN, if there's been a `use` statement for that FQN.
elideFQN :: Imports -> HQ.HashQualified -> HQ.HashQualified
elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name
elideFQN imports hq =
let hash = HQ.toHash hq
name' = do name <- HQ.toName hq

16
parser-typechecker/src/Unison/PrintError.hs
View File

@ -24,10 +24,11 @@ import qualified Unison.HashQualified as HQ
import Unison.Kind (Kind)
import qualified Unison.Kind as Kind
import qualified Unison.Lexer as L
import Unison.Name ( Name )
import Unison.Parser (Ann (..), Annotated, ann)
import qualified Unison.Parser as Parser
import qualified Unison.Reference as R
import Unison.Referent (Referent, pattern Ref')
import Unison.Referent (Referent, pattern Ref)
import Unison.Result (Note (..))
import qualified Unison.Result as Result
import qualified Unison.Settings as Settings
@ -105,7 +106,7 @@ style :: s -> String -> Pretty (AnnotatedText s)
style sty str = Pr.lit . AT.annotate sty $ fromString str
stylePretty :: Color -> Pretty ColorText -> Pretty ColorText
stylePretty sty str = Pr.map (AT.annotate sty) str
stylePretty = Pr.map . AT.annotate
describeStyle :: Color -> Pretty ColorText
describeStyle ErrorSite = "in " <> style ErrorSite "red"
@ -739,7 +740,7 @@ renderCompilerBug env _src bug = mconcat $ case bug of
]
C.UnknownTermReference rf ->
[ "UnknownTermReference:\n"
, showTermRef env (Ref' rf)
, showTermRef env (Ref rf)
]
C.UnknownExistentialVariable v ctx ->
[ "UnknownExistentialVariable:\n"
@ -1218,6 +1219,13 @@ prettyParseError s = \case
, "but there wasn't one. Maybe check your indentation:\n"
, tokenAsErrorSite s tok
]
go Parser.EmptyMatch = mconcat
["I expected some patterns after a "
, style ErrorSite "match"
, "/"
, style ErrorSite "with"
, " but I didn't find any."
]
go Parser.EmptyWatch =
"I expected a non-empty watch expression and not just \">\""
go (Parser.UnknownAbilityConstructor tok _referents) = unknownConstructor "ability" tok
@ -1260,7 +1268,7 @@ prettyParseError s = \case
go (Parser.ResolutionFailures failures) =
Pr.border 2 . prettyResolutionFailures s $ failures
unknownConstructor
:: String -> L.Token HashQualified -> Pretty ColorText
:: String -> L.Token (HashQualified Name) -> Pretty ColorText
unknownConstructor ctorType tok = Pr.lines [
(Pr.wrap . mconcat) [ "I don't know about any "
, fromString ctorType

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

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ViewPatterns #-}
{-# Language OverloadedStrings #-}
@ -81,7 +80,7 @@ import Data.Functor.Compose (Compose(..))
import Data.List hiding (and,or)
import Prelude hiding (abs,and,or,seq)
import qualified Prelude
import Unison.Term hiding (resolve, fresh, float, Text, Ref)
import Unison.Term hiding (resolve, fresh, float, Text, Ref, List)
import Unison.Var (Var, typed)
import Unison.Util.EnumContainers as EC
import Unison.Util.Bytes (Bytes)
@ -192,7 +191,7 @@ enclose keep rec (Let1NamedTop' top v b@(LamsNamed' vs bd) e)
= Just . let1' top [(v, lamb)] . rec (Set.insert v keep)
$ ABT.subst v av e
where
(_, av) = expandSimple keep (v, b)
(_, av) = expandSimple keep (v, b)
keep' = Set.difference keep $ Set.fromList vs
fvs = ABT.freeVars b
evs = Set.toList $ Set.difference fvs keep
@ -470,9 +469,9 @@ fromTerm liftVar t = ANF_ (go $ lambdaLift liftVar t) where
go (Let1Named' v b e) = let1' False [(v, go b)] (go e)
-- top = False because we don't care to emit typechecker notes about TLDs
go (LetRecNamed' bs e) = letRec' False (fmap (second go) bs) (go e)
go e@(Sequence' vs) =
go e@(List' vs) =
if all isLeaf vs then e
else fixup (ABT.freeVars e) (seq (ann e)) (toList vs)
else fixup (ABT.freeVars e) (list (ann e)) (toList vs)
go e@(Ann' tm typ) = Term.ann (ann e) (go tm) typ
go e = error $ "ANF.term: I thought we got all of these\n" <> show e
@ -1163,7 +1162,7 @@ anfBlock (Blank' _) = do
, pure $ TPrm EROR [ev])
anfBlock (TermLink' r) = pure (mempty, pure . TLit $ LM r)
anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r)
anfBlock (Sequence' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms
anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms
where
tms = toList as
anfBlock t = error $ "anf: unhandled term: " ++ show t
@ -1327,7 +1326,7 @@ tyRefs f (MatchRequest m _) = foldMap f (Map.keys m)
tyRefs f (MatchData r _ _) = f r
tyRefs _ _ = mempty
funcLinks
funcLinks
:: Monoid a
=> (Reference -> a)
-> Func v -> a

100
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -1321,7 +1321,7 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a)))
declareForeigns :: Var v => FDecl v ()
declareForeigns = do
declareForeign "IO.openFile.v3" boxIomrToEFBox $
declareForeign "IO.openFile.impl.v3" boxIomrToEFBox $
mkForeignIOF $ \(fnameText :: Text, n :: Int) ->
let fname = (unpack fnameText)
mode = case n of
@ -1331,104 +1331,104 @@ declareForeigns = do
_ -> ReadWriteMode
in openFile fname mode
declareForeign "IO.closeFile.v3" boxToEF0 $ mkForeignIOF hClose
declareForeign "IO.isFileEOF.v3" boxToEFBool $ mkForeignIOF hIsEOF
declareForeign "IO.isFileOpen.v3" boxToEFBool $ mkForeignIOF hIsOpen
declareForeign "IO.isSeekable.v3" boxToEFBool $ mkForeignIOF hIsSeekable
declareForeign "IO.closeFile.impl.v3" boxToEF0 $ mkForeignIOF hClose
declareForeign "IO.isFileEOF.impl.v3" boxToEFBool $ mkForeignIOF hIsEOF
declareForeign "IO.isFileOpen.impl.v3" boxToEFBool $ mkForeignIOF hIsOpen
declareForeign "IO.isSeekable.impl.v3" boxToEFBool $ mkForeignIOF hIsSeekable
declareForeign "IO.seekHandle.v3" seek'handle
declareForeign "IO.seekHandle.impl.v3" seek'handle
. mkForeignIOF $ \(h,sm,n) -> hSeek h sm (fromIntegral (n :: Int))
declareForeign "IO.handlePosition.v3" boxToEFNat
declareForeign "IO.handlePosition.impl.v3" boxToEFNat
-- TODO: truncating integer
. mkForeignIOF $ \h -> fromInteger @Word64 <$> hTell h
declareForeign "IO.getBuffering.v3" get'buffering
declareForeign "IO.getBuffering.impl.v3" get'buffering
$ mkForeignIOF hGetBuffering
declareForeign "IO.setBuffering.v3" boxBoxToEF0
declareForeign "IO.setBuffering.impl.v3" boxBoxToEF0
. mkForeignIOF $ uncurry hSetBuffering
declareForeign "IO.getBytes.v3" boxNatToEFBox . mkForeignIOF $ \(h,n) -> Bytes.fromArray <$> hGet h n
declareForeign "IO.getBytes.impl.v3" boxNatToEFBox . mkForeignIOF $ \(h,n) -> Bytes.fromArray <$> hGet h n
declareForeign "IO.putBytes.v3" boxBoxToEFBox . mkForeignIOF $ \(h,bs) -> hPut h (Bytes.toArray bs)
declareForeign "IO.systemTime.v3" unitToEFNat
declareForeign "IO.putBytes.impl.v3" boxBoxToEFBox . mkForeignIOF $ \(h,bs) -> hPut h (Bytes.toArray bs)
declareForeign "IO.systemTime.impl.v3" unitToEFNat
$ mkForeignIOF $ \() -> getPOSIXTime
declareForeign "IO.getTempDirectory.v3" unitToEFBox
declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox
$ mkForeignIOF $ \() -> getTemporaryDirectory
declareForeign "IO.createTempDirectory" boxToEFBox
declareForeign "IO.createTempDirectory.impl.v3" boxToEFBox
$ mkForeignIOF $ \prefix -> do
temp <- getTemporaryDirectory
createTempDirectory temp prefix
declareForeign "IO.getCurrentDirectory.v3" direct
declareForeign "IO.getCurrentDirectory.impl.v3" direct
. mkForeignIOF $ \() -> getCurrentDirectory
declareForeign "IO.setCurrentDirectory.v3" boxToEF0
declareForeign "IO.setCurrentDirectory.impl.v3" boxToEF0
$ mkForeignIOF setCurrentDirectory
declareForeign "IO.fileExists.v3" boxToEFBool
declareForeign "IO.fileExists.impl.v3" boxToEFBool
$ mkForeignIOF doesPathExist
declareForeign "IO.isDirectory.v3" boxToEFBool
declareForeign "IO.isDirectory.impl.v3" boxToEFBool
$ mkForeignIOF doesDirectoryExist
declareForeign "IO.createDirectory.v3" boxToEF0
declareForeign "IO.createDirectory.impl.v3" boxToEF0
$ mkForeignIOF $ createDirectoryIfMissing True
declareForeign "IO.removeDirectory.v3" boxToEF0
declareForeign "IO.removeDirectory.impl.v3" boxToEF0
$ mkForeignIOF removeDirectoryRecursive
declareForeign "IO.renameDirectory.v3" boxBoxToEF0
declareForeign "IO.renameDirectory.impl.v3" boxBoxToEF0
$ mkForeignIOF $ uncurry renameDirectory
declareForeign "IO.removeFile.v3" boxToEF0
declareForeign "IO.removeFile.impl.v3" boxToEF0
$ mkForeignIOF removeFile
declareForeign "IO.renameFile.v3" boxBoxToEF0
declareForeign "IO.renameFile.impl.v3" boxBoxToEF0
$ mkForeignIOF $ uncurry renameFile
declareForeign "IO.getFileTimestamp.v3" boxToEFNat
declareForeign "IO.getFileTimestamp.impl.v3" boxToEFNat
. mkForeignIOF $ fmap utcTimeToPOSIXSeconds . getModificationTime
declareForeign "IO.getFileSize.v3" boxToEFNat
declareForeign "IO.getFileSize.impl.v3" boxToEFNat
-- TODO: truncating integer
. mkForeignIOF $ \fp -> fromInteger @Word64 <$> getFileSize fp
declareForeign "IO.serverSocket.v3" maybeBoxToEFBox
declareForeign "IO.serverSocket.impl.v3" maybeBoxToEFBox
. mkForeignIOF $ \(mhst :: Maybe Text
, port) ->
fst <$> SYS.bindSock (hostPreference mhst) port
declareForeign "IO.socketPort" boxToEFNat
declareForeign "IO.socketPort.impl.v3" boxToEFNat
. mkForeignIOF $ \(handle :: Socket) -> do
n <- SYS.socketPort handle
return (fromIntegral n :: Word64)
declareForeign "IO.listen.v3" boxToEF0
declareForeign "IO.listen.impl.v3" boxToEF0
. mkForeignIOF $ \sk -> SYS.listenSock sk 2
declareForeign "IO.clientSocket.v3" boxBoxToEFBox
declareForeign "IO.clientSocket.impl.v3" boxBoxToEFBox
. mkForeignIOF $ fmap fst . uncurry SYS.connectSock
declareForeign "IO.closeSocket.v3" boxToEF0
declareForeign "IO.closeSocket.impl.v3" boxToEF0
$ mkForeignIOF SYS.closeSock
declareForeign "IO.socketAccept.v3" boxToEFBox
declareForeign "IO.socketAccept.impl.v3" boxToEFBox
. mkForeignIOF $ fmap fst . SYS.accept
declareForeign "IO.socketSend.v3" boxBoxToEF0
declareForeign "IO.socketSend.impl.v3" boxBoxToEF0
. mkForeignIOF $ \(sk,bs) -> SYS.send sk (Bytes.toArray bs)
declareForeign "IO.socketReceive.v3" boxNatToEFBox
declareForeign "IO.socketReceive.impl.v3" boxNatToEFBox
. mkForeignIOF $ \(hs,n) ->
maybe Bytes.empty Bytes.fromArray <$> SYS.recv hs n
declareForeign "IO.kill.v3" boxTo0 $ mkForeignIOF killThread
declareForeign "IO.kill.impl.v3" boxTo0 $ mkForeignIOF killThread
declareForeign "IO.delay.v3" natToUnit $ mkForeignIOF threadDelay
declareForeign "IO.delay.impl.v3" natToUnit $ mkForeignIOF threadDelay
declareForeign "IO.stdHandle" standard'handle
. mkForeign $ \(n :: Int) -> case n of
@ -1443,34 +1443,34 @@ declareForeigns = do
declareForeign "MVar.newEmpty.v2" unitDirect
. mkForeign $ \() -> newEmptyMVar @Closure
declareForeign "MVar.take.v3" boxToEFBox
declareForeign "MVar.take.impl.v3" boxToEFBox
. mkForeignIOF $ \(mv :: MVar Closure) -> takeMVar mv
declareForeign "MVar.tryTake" boxToMaybeBox
. mkForeign $ \(mv :: MVar Closure) -> tryTakeMVar mv
declareForeign "MVar.put.v3" boxBoxToEF0
declareForeign "MVar.put.impl.v3" boxBoxToEF0
. mkForeignIOF $ \(mv :: MVar Closure, x) -> putMVar mv x
declareForeign "MVar.tryPut" boxBoxToEFBool
declareForeign "MVar.tryPut.impl.v3" boxBoxToEFBool
. mkForeign $ \(mv :: MVar Closure, x) -> tryPutMVar mv x
declareForeign "MVar.swap.v3" boxBoxToEFBox
declareForeign "MVar.swap.impl.v3" boxBoxToEFBox
. mkForeignIOF $ \(mv :: MVar Closure, x) -> swapMVar mv x
declareForeign "MVar.isEmpty" boxToBool
. mkForeign $ \(mv :: MVar Closure) -> isEmptyMVar mv
declareForeign "MVar.read.v3" boxBoxToEFBox
declareForeign "MVar.read.impl.v3" boxBoxToEFBox
. mkForeignIOF $ \(mv :: MVar Closure) -> readMVar mv
declareForeign "MVar.tryRead" boxToMaybeBox
. mkForeign $ \(mv :: MVar Closure) -> tryReadMVar mv
declareForeign "MVar.tryRead.impl.v3" boxToEFBox
. mkForeignIOF $ \(mv :: MVar Closure) -> tryReadMVar mv
declareForeign "Text.toUtf8" boxDirect . mkForeign
$ pure . Bytes.fromArray . encodeUtf8
declareForeign "Text.fromUtf8.v3" boxToEFBox . mkForeign
declareForeign "Text.fromUtf8.impl.v3" boxToEFBox . mkForeign
$ pure . mapLeft (\t -> Failure ioFailureReference (pack ( show t)) unitValue) . decodeUtf8' . Bytes.toArray
declareForeign "Tls.ClientConfig.default" boxBoxDirect . mkForeign
@ -1535,18 +1535,18 @@ declareForeigns = do
declareForeign "Tls.Config.defaultServer" unitDirect . mkForeign $ \() -> do
pure $ (def :: ServerParams) { TLS.serverSupported = defaultSupported }
declareForeign "Tls.newClient" boxBoxToEFBox . mkForeignTls $
declareForeign "Tls.newClient.impl.v3" boxBoxToEFBox . mkForeignTls $
\(config :: TLS.ClientParams,
socket :: SYS.Socket) -> TLS.contextNew socket config
declareForeign "Tls.newServer" boxBoxToEFBox . mkForeignTls $
declareForeign "Tls.newServer.impl.v3" boxBoxToEFBox . mkForeignTls $
\(config :: TLS.ServerParams,
socket :: SYS.Socket) -> TLS.contextNew socket config
declareForeign "Tls.handshake" boxToEFBox . mkForeignTls $
declareForeign "Tls.handshake.impl.v3" boxToEFBox . mkForeignTls $
\(tls :: TLS.Context) -> TLS.handshake tls
declareForeign "Tls.send" boxBoxToEFBox . mkForeignTls $
declareForeign "Tls.send.impl.v3" boxBoxToEFBox . mkForeignTls $
\(tls :: TLS.Context,
bytes :: Bytes.Bytes) -> TLS.sendData tls (Bytes.toLazyByteString bytes)
@ -1556,7 +1556,7 @@ declareForeigns = do
asCert :: PEM -> Either String X.SignedCertificate
asCert pem = X.decodeSignedCertificate $ pemContent pem
in
declareForeign "Tls.decodeCert" boxToEFBox . mkForeign $
declareForeign "Tls.decodeCert.impl.v3" boxToEFBox . mkForeign $
\(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes
declareForeign "Tls.encodeCert" boxDirect . mkForeign $
@ -1568,12 +1568,12 @@ declareForeigns = do
declareForeign "Tls.encodePrivateKey" boxDirect . mkForeign $
\(privateKey :: X.PrivKey) -> pure $ pack $ show privateKey
declareForeign "Tls.receive" boxToEFBox . mkForeignTls $
declareForeign "Tls.receive.impl.v3" boxToEFBox . mkForeignTls $
\(tls :: TLS.Context) -> do
bs <- TLS.recvData tls
pure $ Bytes.fromArray bs
declareForeign "Tls.terminate" boxToEFBox . mkForeignTls $
declareForeign "Tls.terminate.impl.v3" boxToEFBox . mkForeignTls $
\(tls :: TLS.Context) -> TLS.bye tls
declareForeign "Code.dependencies" boxDirect

11
parser-typechecker/src/Unison/Runtime/Decompile.hs
View File

@ -6,17 +6,16 @@
module Unison.Runtime.Decompile
( decompile ) where
import Prelude hiding (seq)
import Unison.Prelude
import Unison.ABT (absChain, substs, pattern AbsN')
import Unison.Term
( Term
, nat, int, char, float, boolean, constructor, app, apps', text, ref
, seq, seq', builtin, termLink, typeLink
, list, list', builtin, termLink, typeLink
)
import Unison.Type
( natRef, intRef, charRef, floatRef, booleanRef, vectorRef
( natRef, intRef, charRef, floatRef, booleanRef, listRef
, termLinkRef, typeLinkRef, anyRef
)
import Unison.Var (Var)
@ -110,16 +109,16 @@ decompileForeign topTerms f
| Just l <- maybeUnwrapForeign typeLinkRef f
= Right $ typeLink () l
| Just s <- unwrapSeq f
= seq' () <$> traverse (decompile topTerms) s
= list' () <$> traverse (decompile topTerms) s
decompileForeign _ _ = err "cannot decompile Foreign"
decompileBytes :: Var v => By.Bytes -> Term v ()
decompileBytes
= app () (builtin () $ fromString "Bytes.fromList")
. seq () . fmap (nat () . fromIntegral) . By.toWord8s
. list () . fmap (nat () . fromIntegral) . By.toWord8s
decompileHashAlgorithm :: Var v => HashAlgorithm -> Term v ()
decompileHashAlgorithm (HashAlgorithm r _) = ref () r
unwrapSeq :: Foreign -> Maybe (Seq Closure)
unwrapSeq = maybeUnwrapForeign vectorRef
unwrapSeq = maybeUnwrapForeign listRef

3
parser-typechecker/src/Unison/Runtime/IOSource.hs
View File

@ -565,4 +565,7 @@ io.bracket acquire release what = io.rethrow (io.IO.bracket_ acquire release wha
-- { IO.throw e } -> h e
-- x -> x
-- handle k in c
|]

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

@ -512,7 +512,7 @@ compile0 env bound t =
msg = "The program being compiled referenced this definition " <>
show r <> "\nbut the compilation environment has no compiled form for this reference."
Just ir -> ir
Term.Sequence' vs -> MakeSequence . toList . fmap (toZ "sequence" t) $ vs
Term.List' vs -> MakeSequence . toList . fmap (toZ "sequence" t) $ vs
_ -> error $ "TODO - don't know how to compile this term:\n"
<> (CT.toPlain . P.render 80 . TP.pretty mempty $ void t)
where
@ -616,13 +616,13 @@ decompileImpl v = case v of
T t -> pure $ Term.text () t
C c -> pure $ Term.char () c
Bs bs -> pure $ Term.builtin() "Bytes.fromList" `Term.apps'` [bsv] where
bsv = Term.seq'() . Sequence.fromList $
bsv = Term.list'() . Sequence.fromList $
[ Term.nat() (fromIntegral w8) | w8 <- Bytes.toWord8s bs ]
Lam _ f _ -> decompileUnderapplied f
Data r cid args ->
Term.apps' <$> pure (Term.constructor() r cid)
<*> traverse decompileImpl (toList args)
Sequence vs -> Term.seq' () <$> traverse decompileImpl vs
Sequence vs -> Term.list' () <$> traverse decompileImpl vs
Ref id symbol ioref -> do
seen <- gets snd
symbol <- pure $ Var.freshenId (fromIntegral id) symbol
@ -809,7 +809,7 @@ decompileIR stack = \case
body' <- decompileIR stack' body
pure $ Term.letRec' False bs' body'
MakeSequence args ->
Term.seq() <$> traverse decompileZ args
Term.list() <$> traverse decompileZ args
Apply lam args ->
Term.apps' <$> decompileIR stack lam <*> traverse decompileZ args
Construct r cid args ->

4
parser-typechecker/src/Unison/Runtime/Machine.hs
View File

@ -1508,7 +1508,7 @@ reflectValue rty = goV
= pure (ANF.Text t)
| Just b <- maybeUnwrapBuiltin f
= pure (ANF.Bytes b)
| Just s <- maybeUnwrapForeign Rf.vectorRef f
| Just s <- maybeUnwrapForeign Rf.listRef f
= ANF.List <$> traverse goV s
| Just l <- maybeUnwrapForeign Rf.termLinkRef f
= pure (ANF.TmLink l)
@ -1569,7 +1569,7 @@ reifyValue0 (rty, rtm) = goV
<$> (goIx gr) <*> goK k
goL (ANF.Text t) = pure . Foreign $ Wrap Rf.textRef t
goL (ANF.List l) = Foreign . Wrap Rf.vectorRef <$> traverse goV l
goL (ANF.List l) = Foreign . Wrap Rf.listRef <$> traverse goV l
goL (ANF.TmLink r) = pure . Foreign $ Wrap Rf.termLinkRef r
goL (ANF.TyLink r) = pure . Foreign $ Wrap Rf.typeLinkRef r
goL (ANF.Bytes b) = pure . Foreign $ Wrap Rf.bytesRef b

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

@ -431,7 +431,7 @@ splitMatrixSeq v (PM rs)
ms = decideSeqPat $ take 1 . dropWhile ((/=v).loc) . matches =<< rs
hint m vrs
| m `elem` [E,C,S] = vrs
| otherwise = (fmap.fmap) (const $ PData Rf.vectorRef) vrs
| otherwise = (fmap.fmap) (const $ PData Rf.listRef) vrs
cases = ms <&> \m ->
let frs = rs >>= splitRowSeq v m
(vrs, pm) = buildMatrix frs
@ -569,7 +569,7 @@ compile spec ctx m@(PM (r:rs))
Nothing -> body r
Just g -> iff mempty g (body r) $ compile spec ctx (PM rs)
| PData rf <- ty
, rf == Rf.vectorRef
, rf == Rf.listRef
= match () (var () v)
$ buildCaseBuiltin spec ctx
<$> splitMatrixSeq v m
@ -716,8 +716,8 @@ determineType = foldMap f
f P.Boolean{} = PData Rf.booleanRef
f P.Text{} = PData Rf.textRef
f P.Char{} = PData Rf.charRef
f P.SequenceLiteral{} = PData Rf.vectorRef
f P.SequenceOp{} = PData Rf.vectorRef
f P.SequenceLiteral{} = PData Rf.listRef
f P.SequenceOp{} = PData Rf.listRef
f (P.Constructor _ r _ _) = PData r
f (P.EffectBind _ r _ _ _) = PReq $ Set.singleton r
f P.EffectPure{} = PReq mempty

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

@ -189,8 +189,8 @@ universalCompare frn = cmpc False
<> cmpl compare us1 us2
<> cmpl (cmpc True) bs1 bs2
cmpc tyEq (Foreign fl) (Foreign fr)
| Just sl <- maybeUnwrapForeign Ty.vectorRef fl
, Just sr <- maybeUnwrapForeign Ty.vectorRef fr
| Just sl <- maybeUnwrapForeign Ty.listRef fl
, Just sr <- maybeUnwrapForeign Ty.listRef fr
= comparing Sq.length sl sr <> fold (Sq.zipWith (cmpc tyEq) sl sr)
| otherwise = frn fl fr
cmpc _ c d = comparing closureNum c d
@ -502,11 +502,11 @@ peekOffS bstk i =
{-# inline peekOffS #-}
pokeS :: Stack 'BX -> Seq Closure -> IO ()
pokeS bstk s = poke bstk (Foreign $ Wrap Ty.vectorRef s)
pokeS bstk s = poke bstk (Foreign $ Wrap Ty.listRef s)
{-# inline pokeS #-}
pokeOffS :: Stack 'BX -> Int -> Seq Closure -> IO ()
pokeOffS bstk i s = pokeOff bstk i (Foreign $ Wrap Ty.vectorRef s)
pokeOffS bstk i s = pokeOff bstk i (Foreign $ Wrap Ty.listRef s)
{-# inline pokeOffS #-}
unull :: Seg 'UN

665
parser-typechecker/src/Unison/Server/Backend.hs Normal file
View File

@ -0,0 +1,665 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Server.Backend where
import Control.Error.Util ( (??) )
import Control.Monad.Except ( ExceptT(..)
, throwError
)
import Data.Bifunctor ( first )
import Data.Tuple.Extra ( dupe )
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.Builtin as B
import qualified Unison.Builtin.Decls as Decls
import Unison.Codebase ( Codebase )
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch ( Branch )
import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Path ( Path )
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Metadata as Metadata
import qualified Unison.Codebase.Path as Path
import qualified Unison.DataDeclaration as DD
import qualified Unison.Server.SearchResult as SR
import qualified Unison.Server.SearchResult' as SR'
import qualified Unison.ABT as ABT
import Unison.Term ( Term )
import qualified Unison.Term as Term
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
import Unison.Name as Name
( unsafeFromText )
import Unison.NameSegment ( NameSegment )
import qualified Unison.NameSegment as NameSegment
import qualified Unison.Names2 as Names
import Unison.Name ( Name )
import qualified Unison.Name as Name
import Unison.Names3 ( Names(..)
, Names0
)
import qualified Unison.Names3 as Names3
import Unison.Parser ( Ann )
import Unison.Prelude
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Util.Pretty as Pretty
import Unison.Reference ( Reference )
import qualified Unison.Reference as Reference
import Unison.Referent ( Referent )
import qualified Unison.Referent as Referent
import Unison.Type ( Type )
import qualified Unison.Type as Type
import qualified Unison.Typechecker as Typechecker
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Star3 as Star3
import Unison.Var ( Var )
import Unison.Server.Types
import Unison.Server.QueryResult
import Unison.Util.SyntaxText ( SyntaxText )
import qualified Unison.Util.SyntaxText as SyntaxText
import Unison.Util.List ( uniqueBy )
import Unison.ShortHash
import qualified Unison.Codebase.ShortBranchHash
as SBH
import Unison.Codebase.ShortBranchHash
( ShortBranchHash )
import qualified Unison.TermPrinter as TermPrinter
import qualified Unison.TypePrinter as TypePrinter
import qualified Unison.DeclPrinter as DeclPrinter
import Unison.Util.Pretty ( Width )
import qualified Data.Text as Text
import qualified Unison.Server.Syntax as Syntax
data TermTag = Doc | Test
deriving (Eq, Ord, Show, Generic)
data TypeTag = Ability | Data
deriving (Eq, Ord, Show, Generic)
data ShallowListEntry v a
= ShallowTermEntry Referent HQ'.HQSegment (Maybe (Type v a)) (Maybe TermTag)
| ShallowTypeEntry Reference HQ'.HQSegment TypeTag
-- The integer here represents the number of children
| ShallowBranchEntry NameSegment ShortBranchHash Int
| ShallowPatchEntry NameSegment
deriving (Eq, Ord, Show, Generic)
listEntryName :: ShallowListEntry v a -> Text
listEntryName = \case
ShallowTermEntry _ s _ _ -> HQ'.toText s
ShallowTypeEntry _ s _ -> HQ'.toText s
ShallowBranchEntry n _ _ -> NameSegment.toText n
ShallowPatchEntry n -> NameSegment.toText n
data BackendError
= NoSuchNamespace Path.Absolute
| BadRootBranch Codebase.GetRootBranchError
| CouldntExpandBranchHash ShortBranchHash
| AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash)
| NoBranchForHash Branch.Hash
| MissingSignatureForTerm Reference
type Backend m a = ExceptT BackendError m a
-- implementation detail of basicParseNames0 and basicPrettyPrintNames0
basicNames0' :: Branch m -> Path -> (Names0, Names0)
basicNames0' root path = (parseNames00, prettyPrintNames00)
where
root0 = Branch.head root
currentBranch = fromMaybe Branch.empty $ Branch.getAt path root
absoluteRootNames0 = Names3.makeAbsolute0 (Branch.toNames0 root0)
currentBranch0 = Branch.head currentBranch
currentPathNames0 = Branch.toNames0 currentBranch0
-- all names, but with local names in their relative form only, rather
-- than absolute; external names appear as absolute
currentAndExternalNames0 =
currentPathNames0
`Names3.unionLeft0` absDot externalNames
where
absDot = Names.prefix0 (Name.unsafeFromText "")
externalNames = rootNames `Names.difference` pathPrefixed currentPathNames0
rootNames = Branch.toNames0 root0
pathPrefixed = case path of
Path.Path (toList -> []) -> const mempty
p -> Names.prefix0 (Path.toName p)
-- parsing should respond to local and absolute names
parseNames00 = currentPathNames0 <> absoluteRootNames0
-- pretty-printing should use local names where available
prettyPrintNames00 = currentAndExternalNames0
basicSuffixifiedNames :: Int -> Branch m -> Path -> PPE.PrettyPrintEnv
basicSuffixifiedNames hashLength root path =
let names0 = basicPrettyPrintNames0 root path
in PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ Names names0 mempty
basicPrettyPrintNames0 :: Branch m -> Path -> Names0
basicPrettyPrintNames0 root = snd . basicNames0' root
basicParseNames0 :: Branch m -> Path -> Names0
basicParseNames0 root = fst . basicNames0' root
loadReferentType ::
(Applicative m, Var v) =>
Codebase m v Ann ->
Referent ->
m (Maybe (Type v Ann))
loadReferentType codebase = \case
Referent.Ref r -> Codebase.getTypeOfTerm codebase r
Referent.Con r cid _ -> getTypeOfConstructor r cid
where
getTypeOfConstructor (Reference.DerivedId r) cid = do
maybeDecl <- Codebase.getTypeDeclaration codebase r
pure $ case maybeDecl of
Nothing -> Nothing
Just decl -> DD.typeOfConstructor (either DD.toDataDecl id decl) cid
getTypeOfConstructor r cid =
error $
"Don't know how to getTypeOfConstructor "
++ show r
++ " "
++ show cid
getRootBranch :: Functor m => Codebase m v Ann -> Backend m (Branch m)
getRootBranch =
ExceptT . (first BadRootBranch <$>) . Codebase.getRootBranch
-- List the immediate children of a namespace
findShallow
:: (Monad m, Var v)
=> Codebase m v Ann
-> Path.Absolute
-> Backend m [ShallowListEntry v Ann]
findShallow codebase path' = do
let path = Path.unabsolute path'
root <- getRootBranch codebase
let mayb = Branch.getAt path root
case mayb of
Nothing -> pure []
Just b -> findShallowInBranch codebase b
findShallowInBranch
:: (Monad m, Var v)
=> Codebase m v Ann
-> Branch m
-> Backend m [ShallowListEntry v Ann]
findShallowInBranch codebase b = do
hashLength <- lift $ Codebase.hashLength codebase
let hqTerm b0 ns r =
let refs = Star3.lookupD1 ns . Branch._terms $ b0
in case length refs of
1 -> HQ'.fromName ns
_ -> HQ'.take hashLength $ HQ'.fromNamedReferent ns r
hqType b0 ns r =
let refs = Star3.lookupD1 ns . Branch._types $ b0
in case length refs of
1 -> HQ'.fromName ns
_ -> HQ'.take hashLength $ HQ'.fromNamedReference ns r
defnCount b =
(R.size . Branch.deepTerms $ Branch.head b)
+ (R.size . Branch.deepTypes $ Branch.head b)
b0 = Branch.head b
termEntries <- for (R.toList . Star3.d1 $ Branch._terms b0) $ \(r, ns) -> do
ot <- lift $ loadReferentType codebase r
-- A term is a doc if its type conforms to the `Doc` type.
let isDoc = case ot of
Just t -> Typechecker.isSubtype t $ Type.ref mempty Decls.docRef
Nothing -> False
-- A term is a test if it has a link of type `IsTest`.
isTest =
Metadata.hasMetadataWithType r (Decls.isTestRef) $ Branch._terms b0
tag = if isDoc then Just Doc else if isTest then Just Test else Nothing
pure $ ShallowTermEntry r (hqTerm b0 ns r) ot tag
typeEntries <- for (R.toList . Star3.d1 $ Branch._types b0) $ \(r, ns) -> do
-- The tag indicates whether the type is a data declaration or an ability.
tag <- case Reference.toId r of
Just r -> do
decl <- lift $ Codebase.getTypeDeclaration codebase r
pure $ case decl of
Just (Left _) -> Ability
_ -> Data
_ -> pure Data
pure $ ShallowTypeEntry r (hqType b0 ns r) tag
let
branchEntries =
[ ShallowBranchEntry ns
(SBH.fullFromHash $ Branch.headHash b)
(defnCount b)
| (ns, b) <- Map.toList $ Branch._children b0
]
patchEntries =
[ ShallowPatchEntry ns
| (ns, (_h, _mp)) <- Map.toList $ Branch._edits b0
]
pure
. List.sortOn listEntryName
$ termEntries
++ typeEntries
++ branchEntries
++ patchEntries
termReferencesByShortHash
:: Monad m => Codebase m v a -> ShortHash -> m (Set Reference)
typeReferencesByShortHash codebase sh = do
fromCodebase <- Codebase.typeReferencesByPrefix codebase sh
let fromBuiltins = Set.filter (\r -> sh == Reference.toShortHash r)
B.intrinsicTypeReferences
pure (fromBuiltins <> Set.map Reference.DerivedId fromCodebase)
typeReferencesByShortHash
:: Monad m => Codebase m v a -> ShortHash -> m (Set Reference)
termReferencesByShortHash codebase sh = do
fromCodebase <- Codebase.termReferencesByPrefix codebase sh
let fromBuiltins = Set.filter (\r -> sh == Reference.toShortHash r)
B.intrinsicTermReferences
pure (fromBuiltins <> Set.map Reference.DerivedId fromCodebase)
termReferentsByShortHash
:: Monad m => Codebase m v a -> ShortHash -> m (Set Referent)
termReferentsByShortHash codebase sh = do
fromCodebase <- Codebase.termReferentsByPrefix codebase sh
let fromBuiltins = Set.map Referent.Ref $ Set.filter
(\r -> sh == Reference.toShortHash r)
B.intrinsicTermReferences
pure (fromBuiltins <> Set.map (fmap Reference.DerivedId) fromCodebase)
-- currentPathNames0 :: Path -> Names0
-- currentPathNames0 = Branch.toNames0 . Branch.head . Branch.getAt
getCurrentPrettyNames :: Path -> Branch m -> Names
getCurrentPrettyNames path root =
Names (basicPrettyPrintNames0 root path) mempty
getCurrentParseNames :: Path -> Branch m -> Names
getCurrentParseNames path root = Names (basicParseNames0 root path) mempty
-- Any absolute names in the input which have `root` as a prefix
-- are converted to names relative to current path. All other names are
-- converted to absolute names. For example:
--
-- e.g. if currentPath = .foo.bar
-- then name foo.bar.baz becomes baz
-- name cat.dog becomes .cat.dog
fixupNamesRelative :: Path.Absolute -> Names0 -> Names0
fixupNamesRelative root = Names3.map0 fixName where
prefix = Path.toName $ Path.unabsolute root
fixName n = if root == Path.absoluteEmpty
then n
else fromMaybe (Name.makeAbsolute n) (Name.stripNamePrefix prefix n)
-- | The output list (of lists) corresponds to the query list.
searchBranchExact
:: Int -> Names -> [HQ.HashQualified Name] -> [[SR.SearchResult]]
searchBranchExact len names queries =
let
searchTypes :: HQ.HashQualified Name -> [SR.SearchResult]
searchTypes query =
-- a bunch of references will match a HQ ref.
let refs = toList $ Names3.lookupHQType query names
mayName r Nothing = HQ'.fromNamedReference "" r
mayName _ (Just n) = n
in refs <&> \r ->
let hqNames = Names3.typeName len r names
in
let primaryName =
mayName r
. lastMay
. sortOn
(\n -> HQ.matchesNamedReference (HQ'.toName n) r query
)
$ toList hqNames
in let aliases = Set.delete primaryName hqNames
in SR.typeResult primaryName r aliases
searchTerms :: HQ.HashQualified Name -> [SR.SearchResult]
searchTerms query =
-- a bunch of references will match a HQ ref.
let refs = toList $ Names3.lookupHQTerm query names
mayName r Nothing = HQ'.fromNamedReferent "" r
mayName _ (Just n) = n
in refs <&> \r ->
let hqNames = Names3.termName len r names
in let primaryName =
mayName r
. lastMay
. sortOn
(\n ->
HQ.matchesNamedReferent (HQ'.toName n) r query
)
$ toList hqNames
in let aliases = Set.delete primaryName hqNames
in SR.termResult primaryName r aliases
in
[ searchTypes q <> searchTerms q | q <- queries ]
hqNameQuery'
:: Monad m
=> Bool
-> Maybe Path
-> Branch m
-> Codebase m v Ann
-> [HQ.HashQualified Name]
-> m QueryResult
hqNameQuery' doSuffixify relativeTo root codebase hqs = do
-- Split the query into hash-only and hash-qualified-name queries.
let (hqnames, hashes) = List.partition (isJust . HQ.toName) hqs
-- Find the terms with those hashes.
termRefs <- filter (not . Set.null . snd) . zip hashes <$> traverse
(termReferentsByShortHash codebase)
(catMaybes (HQ.toHash <$> hashes))
-- Find types with those hashes.
typeRefs <- filter (not . Set.null . snd) . zip hashes <$> traverse
(typeReferencesByShortHash codebase)
(catMaybes (HQ.toHash <$> hashes))
-- Now do the name queries.
-- The hq-name search needs a hash-qualifier length
hqLength <- Codebase.hashLength codebase
-- We need to construct the names that we want to use / search by.
let currentPath = fromMaybe Path.empty relativeTo
parseNames0 = getCurrentParseNames currentPath root
mkTermResult n r = SR.termResult (HQ'.fromHQ' n) r Set.empty
mkTypeResult n r = SR.typeResult (HQ'.fromHQ' n) r Set.empty
-- Transform the hash results a bit
termResults =
(\(n, tms) -> (n, toList $ mkTermResult n <$> toList tms)) <$> termRefs
typeResults =
(\(n, tps) -> (n, toList $ mkTypeResult n <$> toList tps)) <$> typeRefs
-- Suffixify the names
parseNames = (if doSuffixify then Names3.suffixify else id) parseNames0
-- Now do the actual name query
resultss = searchBranchExact hqLength parseNames hqnames
-- Handle query misses correctly
missingRefs =
[ x
| x <- hashes
, isNothing (lookup x termRefs) && isNothing (lookup x typeRefs)
]
(misses, hits) =
List.partition (\(_, results) -> null results) (zip hqs resultss)
-- Gather the results
results =
List.sort
. uniqueBy SR.toReferent
$ (hits ++ termResults ++ typeResults)
>>= snd
pure $ QueryResult (missingRefs ++ (fst <$> misses)) results
hqNameQuery
:: Monad m
=> Maybe Path
-> Branch m
-> Codebase m v Ann
-> [HQ.HashQualified Name]
-> m QueryResult
hqNameQuery = hqNameQuery' False
hqNameQuerySuffixify
:: Monad m
=> Maybe Path
-> Branch m
-> Codebase m v Ann
-> [HQ.HashQualified Name]
-> m QueryResult
hqNameQuerySuffixify = hqNameQuery' True
-- TODO: Move this to its own module
data DefinitionResults v =
DefinitionResults
{ termResults :: Map Reference (DisplayObject (Term v Ann))
, typeResults :: Map Reference (DisplayObject (DD.Decl v Ann))
, noResults :: [HQ.HashQualified Name]
}
-- Separates type references from term references and returns types and terms,
-- respectively. For terms that are constructors, turns them into their data
-- types.
collateReferences
:: Foldable f
=> Foldable g
=> f Reference -- types requested
-> g Referent -- terms requested, including ctors
-> (Set Reference, Set Reference)
collateReferences (toList -> types) (toList -> terms) =
let terms' = [ r | Referent.Ref r <- terms ]
types' = [ r | Referent.Con r _ _ <- terms ]
in (Set.fromList types' <> Set.fromList types, Set.fromList terms')
expandShortBranchHash
:: Monad m => Codebase m v a -> ShortBranchHash -> Backend m Branch.Hash
expandShortBranchHash codebase hash = do
hashSet <- lift $ Codebase.branchHashesByPrefix codebase hash
len <- lift $ Codebase.branchHashLength codebase
case Set.toList hashSet of
[] -> throwError $ CouldntExpandBranchHash hash
[h] -> pure h
_ ->
throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet
prettyType
:: Var v
=> Width
-> PPE.PrettyPrintEnvDecl
-> Type v Ann
-> Syntax.SyntaxText
prettyType width ppe =
mungeSyntaxText . Pretty.render width . TypePrinter.pretty0
(PPE.suffixifiedPPE ppe)
mempty
(-1)
mungeSyntaxText
:: Functor g => g (SyntaxText.Element Reference) -> g Syntax.Element
mungeSyntaxText = fmap Syntax.convertElement
prettyDefinitionsBySuffixes
:: forall v m
. Monad m
=> Var v
=> Maybe Path
-> Maybe Branch.Hash
-> Maybe Width
-> Codebase m v Ann
-> [HQ.HashQualified Name]
-> Backend m DefinitionDisplayResults
prettyDefinitionsBySuffixes relativeTo root renderWidth codebase query = do
branch <- resolveBranchHash root codebase
DefinitionResults terms types misses <- definitionsBySuffixes relativeTo
branch
codebase
query
hqLength <- lift $ Codebase.hashLength codebase
-- We might like to make sure that the user search terms get used as
-- the names in the pretty-printer, but the current implementation
-- doesn't.
let
printNames = getCurrentPrettyNames (fromMaybe Path.empty relativeTo) branch
parseNames = getCurrentParseNames (fromMaybe Path.empty relativeTo) branch
ppe = PPE.fromNamesDecl hqLength printNames
width = mayDefault renderWidth
termFqns :: Map Reference (Set Text)
termFqns = Map.mapWithKey f terms
where
f k _ =
R.lookupRan (Referent.Ref' k)
. R.filterDom (\n -> "." `Text.isPrefixOf` n && n /= ".")
. R.mapDom Name.toText
. Names.terms
$ currentNames parseNames
typeFqns :: Map Reference (Set Text)
typeFqns = Map.mapWithKey f types
where
f k _ =
R.lookupRan k
. R.filterDom (\n -> "." `Text.isPrefixOf` n && n /= ".")
. R.mapDom Name.toText
. Names.types
$ currentNames parseNames
flatten = Set.toList . fromMaybe Set.empty
mkTermDefinition r tm = mk =<< lift (Codebase.getTypeOfTerm codebase r)
where
mk Nothing = throwError $ MissingSignatureForTerm r
mk (Just typeSig) =
pure
. TermDefinition
(flatten $ Map.lookup r termFqns)
( Text.pack
. Pretty.render width
. fmap SyntaxText.toPlain
. TermPrinter.pretty0 @v (PPE.suffixifiedPPE ppe)
TermPrinter.emptyAc
$ Term.ref mempty r
)
(fmap mungeSyntaxText tm)
$ prettyType width ppe typeSig
mkTypeDefinition r tp =
TypeDefinition
(flatten $ Map.lookup r typeFqns)
( Text.pack
. Pretty.render width
. fmap SyntaxText.toPlain
. TypePrinter.pretty0 @v (PPE.suffixifiedPPE ppe) mempty (-1)
$ Type.ref () r
)
$ fmap mungeSyntaxText tp
typeDefinitions =
Map.mapWithKey mkTypeDefinition $ typesToSyntax width ppe types
termDefinitions <- Map.traverseWithKey mkTermDefinition
$ termsToSyntax width ppe terms
let renderedDisplayTerms = Map.mapKeys Reference.toText termDefinitions
renderedDisplayTypes = Map.mapKeys Reference.toText typeDefinitions
renderedMisses = fmap HQ.toText misses
pure $ DefinitionDisplayResults renderedDisplayTerms
renderedDisplayTypes
renderedMisses
resolveBranchHash
:: Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m)
resolveBranchHash h codebase = case h of
Nothing -> getRootBranch codebase
Just bhash -> do
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
mayBranch ?? NoBranchForHash bhash
definitionsBySuffixes
:: forall m v
. Monad m
=> Var v
=> Maybe Path
-> Branch m
-> Codebase m v Ann
-> [HQ.HashQualified Name]
-> Backend m (DefinitionResults v)
definitionsBySuffixes relativeTo branch codebase query = do
-- First find the hashes by name and note any query misses.
QueryResult misses results <- lift
$ hqNameQuerySuffixify relativeTo branch codebase query
-- Now load the terms/types for those hashes.
results' <- lift $ loadSearchResults codebase results
let termTypes :: Map.Map Reference (Type v Ann)
termTypes = Map.fromList
[ (r, t) | SR'.Tm _ (Just t) (Referent.Ref r) _ <- results' ]
(collatedTypes, collatedTerms) = collateReferences
(mapMaybe SR'.tpReference results')
(mapMaybe SR'.tmReferent results')
-- load the `collatedTerms` and types into a Map Reference.Id Term/Type
-- for later
loadedDerivedTerms <-
lift $ fmap (Map.fromList . catMaybes) . for (toList collatedTerms) $ \case
Reference.DerivedId i -> fmap (i, ) <$> Codebase.getTerm codebase i
Reference.Builtin{} -> pure Nothing
loadedDerivedTypes <-
lift $ fmap (Map.fromList . catMaybes) . for (toList collatedTypes) $ \case
Reference.DerivedId i ->
fmap (i, ) <$> Codebase.getTypeDeclaration codebase i
Reference.Builtin{} -> pure Nothing
-- Populate DisplayObjects for the search results, in anticipation of
-- rendering the definitions.
loadedDisplayTerms <- fmap Map.fromList . for (toList collatedTerms) $ \case
r@(Reference.DerivedId i) -> do
let tm = Map.lookup i loadedDerivedTerms
-- We add a type annotation to the term using if it doesn't
-- already have one that the user provided
pure . (r, ) $ case liftA2 (,) tm (Map.lookup r termTypes) of
Nothing -> MissingObject $ Reference.idToShortHash i
Just (tm, typ) -> case tm of
Term.Ann' _ _ -> UserObject tm
_ -> UserObject (Term.ann (ABT.annotation tm) tm typ)
r@(Reference.Builtin _) -> pure (r, BuiltinObject)
let loadedDisplayTypes = Map.fromList . (`fmap` toList collatedTypes) $ \case
r@(Reference.DerivedId i) ->
(r, )
. maybe (MissingObject $ Reference.idToShortHash i) UserObject
$ Map.lookup i loadedDerivedTypes
r@(Reference.Builtin _) -> (r, BuiltinObject)
pure $ DefinitionResults loadedDisplayTerms loadedDisplayTypes misses
termsToSyntax
:: Var v
=> Ord a
=> Int
-> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayObject (Term v a))
-> Map Reference.Reference (DisplayObject SyntaxText)
termsToSyntax width ppe0 terms =
Map.fromList . map go . Map.toList $ Map.mapKeys
(first (PPE.termName ppeDecl . Referent.Ref) . dupe)
terms
where
ppeBody r = PPE.declarationPPE ppe0 r
ppeDecl = PPE.unsuffixifiedPPE ppe0
go ((n, r), dt) =
(r, Pretty.render width . TermPrinter.prettyBinding (ppeBody r) n <$> dt)
typesToSyntax
:: Var v
=> Ord a
=> Int
-> PPE.PrettyPrintEnvDecl
-> Map Reference.Reference (DisplayObject (DD.Decl v a))
-> Map Reference.Reference (DisplayObject SyntaxText)
typesToSyntax width ppe0 types =
Map.fromList $ map go . Map.toList $ Map.mapKeys
(first (PPE.typeName ppeDecl) . dupe)
types
where
ppeBody r = PPE.declarationPPE ppe0 r
ppeDecl = PPE.unsuffixifiedPPE ppe0
go ((n, r), dt) =
( r
, (\case
Left d ->
Pretty.render width $ DeclPrinter.prettyEffectDecl (ppeBody r) r n d
Right d ->
Pretty.render width $ DeclPrinter.prettyDataDecl (ppeBody r) r n d
)
<$> dt
)
loadSearchResults
:: (Var v, Applicative m)
=> Codebase m v Ann
-> [SR.SearchResult]
-> m [SR'.SearchResult' v Ann]
loadSearchResults c = traverse loadSearchResult
where
loadSearchResult = \case
SR.Tm (SR.TermResult name r aliases) -> do
typ <- loadReferentType c r
pure $ SR'.Tm name typ r aliases
SR.Tp (SR.TypeResult name r aliases) -> do
dt <- loadTypeDisplayObject c r
pure $ SR'.Tp name dt r aliases
loadTypeDisplayObject
:: Applicative m
=> Codebase m v Ann
-> Reference
-> m (DisplayObject (DD.Decl v Ann))
loadTypeDisplayObject c = \case
Reference.Builtin _ -> pure BuiltinObject
Reference.DerivedId id ->
maybe (MissingObject $ Reference.idToShortHash id) UserObject
<$> Codebase.getTypeDeclaration c id

170
parser-typechecker/src/Unison/Server/CodebaseServer.hs Normal file
View File

@ -0,0 +1,170 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.CodebaseServer where
import Data.Aeson ( )
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString as Strict
import Data.OpenApi ( URL(..)
, Info(..)
, License(..)
, OpenApi
)
import Data.Proxy ( Proxy(..) )
import GHC.Generics ( )
import Network.HTTP.Types.Status ( ok200 )
import Network.Wai ( responseLBS
, Request
, queryString
)
import Network.Wai.Handler.Warp ( runSettings
, withApplicationSettings
, defaultSettings
, Port
, setPort
, setHost
)
import Servant.API (Headers, Get
, JSON
, Raw
, (:>)
, type (:<|>)(..)
)
import Servant.API.Experimental.Auth ( AuthProtect )
import Servant.Server.Experimental.Auth
( AuthHandler
, AuthServerData
, mkAuthHandler
)
import Servant.Docs ( DocIntro(DocIntro)
, docsWithIntros
, markdown
)
import Servant.Server ( Application
, Context(..)
, Server
, ServerError(..)
, Tagged(Tagged)
, err401
)
import Unison.Codebase ( Codebase )
import Unison.Parser ( Ann )
import Unison.Server.Endpoints.ListNamespace
( NamespaceAPI
, serveNamespace
)
import Unison.Server.Endpoints.GetDefinitions
( DefinitionsAPI
, serveDefinitions
)
import Unison.Server.Types ( mungeString )
import Unison.Var ( Var )
import Servant.OpenApi ( HasOpenApi(toOpenApi) )
import Servant ( Header
, addHeader
, throwError
, serveWithContext
)
import Control.Lens ( (&)
, (.~)
)
import Data.OpenApi.Lens ( info )
import qualified Data.Text as Text
import Data.Foldable ( Foldable(toList) )
import System.Random.Stateful ( getStdGen
, newAtomicGenM
, uniformByteStringM
)
import qualified Data.ByteString.Base64 as Base64
type OpenApiJSON = "openapi.json"
:> Get '[JSON] (Headers '[Header "Access-Control-Allow-Origin" String] OpenApi)
type DocAPI = AuthProtect "token-auth" :> (UnisonAPI :<|> OpenApiJSON :<|> Raw)
type UnisonAPI = NamespaceAPI :<|> DefinitionsAPI
type instance AuthServerData (AuthProtect "token-auth") = ()
genAuthServerContext
:: Strict.ByteString -> Context (AuthHandler Request ()': '[])
genAuthServerContext token = authHandler token :. EmptyContext
authHandler :: Strict.ByteString -> AuthHandler Request ()
authHandler token = mkAuthHandler handler
where
throw401 msg = throwError $ err401 { errBody = msg }
handler req =
maybe (throw401 "Authentication token missing or incorrect")
(const $ pure ())
. lookup token
$ queryString req
openAPI :: OpenApi
openAPI = toOpenApi api & info .~ infoObject
infoObject :: Info
infoObject = mempty
{ _infoTitle = "Unison Codebase Manager API"
, _infoDescription =
Just "Provides operations for querying and manipulating a Unison codebase."
, _infoLicense = Just . License "MIT" . Just $ URL
"https://github.com/unisonweb/unison/blob/trunk/LICENSE"
, _infoVersion = "1.0"
}
docsBS :: Lazy.ByteString
docsBS = mungeString . markdown $ docsWithIntros [intro] api
where
intro = DocIntro (Text.unpack $ _infoTitle infoObject)
(toList $ Text.unpack <$> _infoDescription infoObject)
docAPI :: Proxy DocAPI
docAPI = Proxy
api :: Proxy UnisonAPI
api = Proxy
app :: Var v => Codebase IO v Ann -> Strict.ByteString -> Application
app codebase token =
serveWithContext docAPI (genAuthServerContext token) $ server codebase
genToken :: IO Strict.ByteString
genToken = do
gen <- getStdGen
g <- newAtomicGenM gen
Base64.encode <$> uniformByteStringM 24 g
-- Returns the auth token required for accessing the server.
-- It expects the token as a query parameter. E.g. if the token is "abc"
-- and `port` is 80, then the server can only be accessed at
-- http://127.0.0.1:80?abc
startOnPort :: Var v => Codebase IO v Ann -> Port -> IO Strict.ByteString
startOnPort codebase port = do
token <- genToken
let settings = setHost "127.0.0.1" $ setPort port defaultSettings
runSettings settings $ app codebase token
pure token
-- The auth token required for accessing the server is passed to the function k
start
:: Var v => Codebase IO v Ann -> (Strict.ByteString -> Port -> IO ()) -> IO ()
start codebase k = do
token <- genToken
let settings = setHost "127.0.0.1" defaultSettings
withApplicationSettings settings (pure $ app codebase token) (k token)
server :: Var v => Codebase IO v Ann -> Server DocAPI
server codebase _ =
(serveNamespace codebase :<|> serveDefinitions codebase)
:<|> addHeader "*"
<$> serveOpenAPI
:<|> Tagged serveDocs
where
serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS
serveOpenAPI = pure openAPI
plain = ("Content-Type", "text/plain")

108
parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs Normal file
View File

@ -0,0 +1,108 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.Endpoints.GetDefinitions where
import Control.Error ( runExceptT )
import qualified Data.Text as Text
import Servant ( Get
, JSON
, QueryParam
, QueryParams
, throwError
, (:>)
)
import Servant.Docs ( DocQueryParam(..)
, ParamKind(..)
, ToParam(..)
, ToSample(..)
, noSamples
)
import Servant.Server ( Handler )
import qualified Unison.Codebase.Path as Path
import qualified Unison.HashQualified as HQ
import Unison.Parser ( Ann )
import qualified Unison.Server.Backend as Backend
import Unison.Server.Types ( HashQualifiedName
, DefinitionDisplayResults
, defaultWidth
)
import Unison.Server.Errors ( backendError
, badNamespace
)
import Unison.Util.Pretty ( Width )
import Unison.Var ( Var )
import Unison.Codebase ( Codebase )
import Unison.Codebase.ShortBranchHash
( ShortBranchHash )
import Unison.Prelude
type DefinitionsAPI =
"getDefinition" :> QueryParam "rootBranch" ShortBranchHash
:> QueryParam "relativeTo" HashQualifiedName
:> QueryParams "names" HashQualifiedName
:> QueryParam "renderWidth" Width
:> Get '[JSON] DefinitionDisplayResults
instance ToParam (QueryParam "renderWidth" Width) where
toParam _ = DocQueryParam
"renderWidth"
["80", "100", "120"]
( "The preferred maximum line width (in characters) of the source code of "
<> "definitions to be rendered. "
<> "If left absent, the render width is assumed to be "
<> show defaultWidth
<> "."
)
Normal
instance ToParam (QueryParam "relativeTo" HashQualifiedName) where
toParam _ = DocQueryParam
"relativeTo"
[".", ".base", "foo.bar"]
("The namespace relative to which the `names` parameter is to be resolved. "
<> "If left absent, the root namespace will be used."
)
Normal
instance ToParam (QueryParam "rootBranch" ShortBranchHash) where
toParam _ = DocQueryParam
"rootBranch"
["#abc123"]
( "The hash or hash prefix of the namespace root. "
<> "If left absent, the most recent root will be used."
)
Normal
instance ToParam (QueryParams "names" Text) where
toParam _ = DocQueryParam
"names"
[".base.List", "foo.bar", "#abc123"]
("A fully qualified name, hash-qualified name, " <> "or hash.")
List
instance ToSample DefinitionDisplayResults where
toSamples _ = noSamples
serveDefinitions
:: Var v
=> Codebase IO v Ann
-> Maybe ShortBranchHash
-> Maybe HashQualifiedName
-> [HashQualifiedName]
-> Maybe Width
-> Handler DefinitionDisplayResults
serveDefinitions codebase mayRoot relativePath hqns width = do
rel <- fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath
ea <- liftIO . runExceptT $ do
root <- traverse (Backend.expandShortBranchHash codebase) mayRoot
Backend.prettyDefinitionsBySuffixes rel root width codebase
$ HQ.unsafeFromText
<$> hqns
errFromEither backendError ea
where
parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
errFromEither f = either (throwError . f) pure

248
parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs Normal file
View File

@ -0,0 +1,248 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.Endpoints.ListNamespace where
import Control.Error ( runExceptT )
import Data.Aeson ( ToJSON )
import Data.OpenApi ( ToSchema )
import Servant ( Get
, JSON
, QueryParam
, ServerError(errBody)
, err400
, throwError
, (:>)
)
import Servant.Docs ( DocQueryParam(..)
, ParamKind(Normal)
, ToParam(..)
, ToSample(..)
)
import Servant.OpenApi ( )
import Servant.Server ( Handler )
import Unison.Prelude
import Unison.Codebase ( Codebase )
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.Path as Path
import qualified Unison.Hash as Hash
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
import qualified Unison.Name as Name
import qualified Unison.NameSegment as NameSegment
import Unison.Parser ( Ann )
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Server.Backend as Backend
import Unison.Server.Errors ( backendError
, badHQN
, badNamespace
, rootBranchError
)
import Unison.Server.Types ( HashQualifiedName
, Size
, UnisonHash
, UnisonName
, mayDefault
, formatType
)
import Unison.Util.Pretty ( Width )
import Unison.Var ( Var )
import qualified Unison.Codebase.ShortBranchHash
as SBH
import qualified Unison.ShortHash as ShortHash
import qualified Data.Text as Text
import Unison.Server.Syntax ( SyntaxText )
type NamespaceAPI =
"list" :> QueryParam "namespace" HashQualifiedName
:> Get '[JSON] NamespaceListing
instance ToParam (QueryParam "namespace" Text) where
toParam _ =
DocQueryParam
"namespace"
[".", ".base.List", "foo.bar"]
"The fully qualified name of a namespace. The leading `.` is optional."
Normal
instance ToSample NamespaceListing where
toSamples _ =
[ ( "When no value is provided for `namespace`, the root namespace `.` is "
<> "listed by default"
, NamespaceListing
(Just ".")
"#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5"
[Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg" 1244]
)
]
data NamespaceListing = NamespaceListing
{ namespaceListingName :: Maybe UnisonName,
namespaceListingHash :: UnisonHash,
namespaceListingChildren :: [NamespaceObject]
}
deriving (Generic, Show)
instance ToJSON NamespaceListing
deriving instance ToSchema NamespaceListing
data NamespaceObject
= Subnamespace NamedNamespace
| TermObject NamedTerm
| TypeObject NamedType
| PatchObject NamedPatch
deriving (Generic, Show)
instance ToJSON NamespaceObject
deriving instance ToSchema NamespaceObject
data NamedNamespace = NamedNamespace
{ namespaceName :: UnisonName
, namespaceHash :: UnisonHash
, namespaceSize :: Size
}
deriving (Generic, Show)
instance ToJSON NamedNamespace
deriving instance ToSchema NamedNamespace
data NamedTerm = NamedTerm
{ termName :: HashQualifiedName
, termHash :: UnisonHash
, termType :: Maybe SyntaxText
, termTag :: Maybe Backend.TermTag
}
deriving (Generic, Show)
instance ToJSON NamedTerm
deriving instance ToSchema NamedTerm
data NamedType = NamedType
{ typeName :: HashQualifiedName
, typeHash :: UnisonHash
, typeTag :: Backend.TypeTag
}
deriving (Generic, Show)
instance ToJSON NamedType
deriving instance ToSchema NamedType
newtype NamedPatch = NamedPatch { patchName :: HashQualifiedName }
deriving (Generic, Show)
instance ToJSON NamedPatch
deriving instance ToSchema NamedPatch
newtype KindExpression = KindExpression {kindExpressionText :: Text}
deriving (Generic, Show)
instance ToJSON KindExpression
deriving instance ToSchema KindExpression
instance ToJSON Backend.TermTag
deriving instance ToSchema Backend.TermTag
instance ToJSON Backend.TypeTag
deriving instance ToSchema Backend.TypeTag
backendListEntryToNamespaceObject
:: Var v
=> PPE.PrettyPrintEnv
-> Maybe Width
-> Backend.ShallowListEntry v a
-> NamespaceObject
backendListEntryToNamespaceObject ppe typeWidth = \case
Backend.ShallowTermEntry r name mayType tag -> TermObject $ NamedTerm
{ termName = HQ'.toText name
, termHash = Referent.toText r
, termType = formatType ppe (mayDefault typeWidth) <$> mayType
, termTag = tag
}
Backend.ShallowTypeEntry r name tag -> TypeObject $ NamedType
{ typeName = HQ'.toText name
, typeHash = Reference.toText r
, typeTag = tag
}
Backend.ShallowBranchEntry name hash size -> Subnamespace $ NamedNamespace
{ namespaceName = NameSegment.toText name
, namespaceHash = "#" <> SBH.toText hash
, namespaceSize = size
}
Backend.ShallowPatchEntry name ->
PatchObject . NamedPatch $ NameSegment.toText name
serveNamespace
:: Var v
=> Codebase IO v Ann
-> Maybe HashQualifiedName
-> Handler NamespaceListing
serveNamespace codebase mayHQN = case mayHQN of
Nothing -> serveNamespace codebase $ Just "."
Just hqn -> do
parsedName <- parseHQN hqn
hashLength <- liftIO $ Codebase.hashLength codebase
case parsedName of
HQ.NameOnly n -> do
path' <- parsePath $ Name.toString n
gotRoot <- liftIO $ Codebase.getRootBranch codebase
root <- errFromEither rootBranchError gotRoot
let
p = either id (Path.Absolute . Path.unrelative) $ Path.unPath' path'
ppe =
Backend.basicSuffixifiedNames hashLength root $ Path.fromPath' path'
entries <- findShallow p
processEntries
ppe
(Just $ Name.toText n)
(("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash root)
entries
HQ.HashOnly sh -> case SBH.fromText $ ShortHash.toText sh of
Nothing ->
throwError
. badNamespace "Malformed branch hash."
$ ShortHash.toString sh
Just h -> doBackend $ do
hash <- Backend.expandShortBranchHash codebase h
branch <- Backend.resolveBranchHash (Just hash) codebase
entries <- Backend.findShallowInBranch codebase branch
let ppe = Backend.basicSuffixifiedNames hashLength branch mempty
sbh = Text.pack . show $ SBH.fullFromHash hash
processEntries ppe Nothing sbh entries
HQ.HashQualified _ _ -> hashQualifiedNotSupported
where
errFromMaybe e = maybe (throwError e) pure
errFromEither f = either (throwError . f) pure
parseHQN hqn = errFromMaybe (badHQN hqn) $ HQ.fromText hqn
parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
doBackend a = do
ea <- liftIO $ runExceptT a
errFromEither backendError ea
findShallow p = doBackend $ Backend.findShallow codebase p
processEntries ppe name hash entries =
pure . NamespaceListing name hash $ fmap
(backendListEntryToNamespaceObject ppe Nothing)
entries
hashQualifiedNotSupported = throwError $ err400
{ errBody = "This server does not yet support searching namespaces by "
<> "hash-qualified name."
}

83
parser-typechecker/src/Unison/Server/Errors.hs Normal file
View File

@ -0,0 +1,83 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.Errors where
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import Servant (ServerError (..), err400, err404, err500)
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.ShortBranchHash as SBH
import qualified Unison.Reference as Reference
import qualified Unison.Server.Backend as Backend
import Unison.Server.Types
( HashQualifiedName,
munge,
mungeShow,
mungeString,
)
badHQN :: HashQualifiedName -> ServerError
badHQN hqn = err400
{ errBody = Text.encodeUtf8 (Text.fromStrict hqn)
<> " is not a well-formed name, hash, or hash-qualified name. "
<> "I expected something like `foo`, `#abc123`, or `foo#abc123`."
}
backendError :: Backend.BackendError -> ServerError
backendError = \case
Backend.NoSuchNamespace n ->
noSuchNamespace . Path.toText $ Path.unabsolute n
Backend.BadRootBranch e -> rootBranchError e
Backend.NoBranchForHash h ->
noSuchNamespace . Text.toStrict . Text.pack $ show h
Backend.CouldntExpandBranchHash h ->
noSuchNamespace . Text.toStrict . Text.pack $ show h
Backend.AmbiguousBranchHash sbh hashes ->
ambiguousNamespace (SBH.toText sbh) (Set.map SBH.toText hashes)
Backend.MissingSignatureForTerm r -> missingSigForTerm $ Reference.toText r
rootBranchError :: Codebase.GetRootBranchError -> ServerError
rootBranchError rbe = err500
{ errBody = case rbe of
Codebase.NoRootBranch -> "Couldn't identify a root namespace."
Codebase.CouldntLoadRootBranch h ->
"Couldn't load root branch " <> mungeShow h
Codebase.CouldntParseRootBranch h ->
"Couldn't parse root branch head " <> mungeShow h
}
badNamespace :: String -> String -> ServerError
badNamespace err namespace = err400
{ errBody = "Malformed namespace: "
<> mungeString namespace
<> ". "
<> mungeString err
}
noSuchNamespace :: HashQualifiedName -> ServerError
noSuchNamespace namespace =
err404 { errBody = "The namespace " <> munge namespace <> " does not exist." }
ambiguousNamespace :: HashQualifiedName -> Set HashQualifiedName -> ServerError
ambiguousNamespace name namespaces = err400
{ errBody = "Ambiguous namespace reference: "
<> munge name
<> ". It could refer to any of "
<> mungeShow (Set.toList namespaces)
}
missingSigForTerm :: HashQualifiedName -> ServerError
missingSigForTerm r = err500
{ errBody = "The type signature for reference "
<> munge r
<> " is missing! "
<> "This means something might be wrong with the codebase, "
<> "or the term was deleted just now. "
<> "Try making the request again."
}

11
parser-typechecker/src/Unison/Server/QueryResult.hs Normal file
View File

@ -0,0 +1,11 @@
module Unison.Server.QueryResult where
import qualified Unison.HashQualified as HQ
import Unison.Name ( Name )
import qualified Unison.Server.SearchResult as SR
data QueryResult = QueryResult
{ misses :: [HQ.HashQualified Name]
, hits :: [SR.SearchResult]
}

22
parser-typechecker/src/Unison/Codebase/Editor/SearchResult'.hs → parser-typechecker/src/Unison/Server/SearchResult'.hs
View File

@ -1,31 +1,40 @@
{-# LANGUAGE PatternSynonyms #-}
module Unison.Codebase.Editor.SearchResult' where
module Unison.Server.SearchResult' where
import Unison.Prelude
import Unison.Referent (Referent)
import Unison.Reference (Reference)
import qualified Unison.HashQualified' as HQ'
import qualified Data.Set as Set
import qualified Unison.DataDeclaration as DD
import qualified Unison.Codebase.Editor.DisplayThing as DT
import qualified Unison.Codebase.Editor.DisplayObject as DT
import qualified Unison.Type as Type
import Unison.DataDeclaration (Decl)
import Unison.Codebase.Editor.DisplayThing (DisplayThing)
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
import Unison.Type (Type)
import Unison.Name (Name)
import qualified Unison.LabeledDependency as LD
import Unison.LabeledDependency (LabeledDependency)
import qualified Data.Set as Set
data SearchResult' v a
= Tm' (TermResult' v a)
| Tp' (TypeResult' v a)
deriving (Eq, Show)
data TermResult' v a =
TermResult' HQ'.HashQualified (Maybe (Type v a)) Referent (Set HQ'.HashQualified)
TermResult' (HQ'.HashQualified Name)
(Maybe (Type v a))
Referent
(Set (HQ'.HashQualified Name))
deriving (Eq, Show)
data TypeResult' v a =
TypeResult' HQ'.HashQualified (DisplayThing (Decl v a)) Reference (Set HQ'.HashQualified)
TypeResult' (HQ'.HashQualified Name)
(DisplayObject (Decl v a))
Reference
(Set (HQ'.HashQualified Name))
deriving (Eq, Show)
pattern Tm n t r as = Tm' (TermResult' n t r as)
@ -50,3 +59,4 @@ labeledDependencies = \case
Set.insert (LD.referent r) $ maybe mempty (Set.map LD.typeRef . Type.dependencies) t
Tp' (TypeResult' _ d r _) ->
Set.map LD.typeRef . Set.insert r $ maybe mempty DD.declDependencies (DT.toMaybe d)

23
parser-typechecker/src/Unison/Codebase/SearchResult.hs → parser-typechecker/src/Unison/Server/SearchResult.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE PatternSynonyms #-}
module Unison.Codebase.SearchResult where
module Unison.Server.SearchResult where
import Unison.Prelude
@ -15,44 +15,45 @@ import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Util.Relation as R
-- this Ord instance causes types < terms
data SearchResult = Tp TypeResult | Tm TermResult deriving (Eq, Ord, Show)
data TermResult = TermResult
{ termName :: HashQualified
{ termName :: HashQualified Name
, referent :: Referent
, termAliases :: Set HashQualified
, termAliases :: Set (HashQualified Name)
} deriving (Eq, Ord, Show)
data TypeResult = TypeResult
{ typeName :: HashQualified
{ typeName :: HashQualified Name
, reference :: Reference
, typeAliases :: Set HashQualified
, typeAliases :: Set (HashQualified Name)
} deriving (Eq, Ord, Show)
pattern Tm' hq r as = Tm (TermResult hq r as)
pattern Tp' hq r as = Tp (TypeResult hq r as)
termResult :: HashQualified -> Referent -> Set HashQualified -> SearchResult
termResult
:: HashQualified Name -> Referent -> Set (HashQualified Name) -> SearchResult
termResult hq r as = Tm (TermResult hq r as)
termSearchResult :: Names0 -> Name -> Referent -> SearchResult
termSearchResult b n r =
termResult (Names._hqTermName b n r) r (Names._hqTermAliases b n r)
typeResult :: HashQualified -> Reference -> Set HashQualified -> SearchResult
typeResult
:: HashQualified Name -> Reference -> Set (HashQualified Name) -> SearchResult
typeResult hq r as = Tp (TypeResult hq r as)
typeSearchResult :: Names0 -> Name -> Reference -> SearchResult
typeSearchResult b n r =
typeResult (Names._hqTypeName b n r) r (Names._hqTypeAliases b n r)
name :: SearchResult -> HashQualified
name :: SearchResult -> HashQualified Name
name = \case
Tm t -> termName t
Tp t -> typeName t
aliases :: SearchResult -> Set HashQualified
aliases :: SearchResult -> Set (HashQualified Name)
aliases = \case
Tm t -> termAliases t
Tp t -> typeAliases t
@ -81,3 +82,5 @@ _fromNames n0@(Names terms types) = typeResults <> termResults where
termResults =
[ termResult (Names._hqTermName n0 name r) r (Names._hqTermAliases n0 name r)
| (name, r) <- R.toList terms]

138
parser-typechecker/src/Unison/Server/Syntax.hs Normal file
View File

@ -0,0 +1,138 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- Duplicate of the Unison.Util.SyntaxText module, but we expect these to
-- evolve separately. This is the version which is outward facing
-- to the server frontend.
module Unison.Server.Syntax where
import Data.Aeson ( ToJSON )
import Data.OpenApi ( ToSchema(..) )
import Unison.Prelude
import qualified Unison.HashQualified as HashQualified
import Unison.Pattern ( SeqOp(..) )
import Unison.Util.AnnotatedText ( AnnotatedText(..)
, Segment(..)
, annotate
, segment
)
import qualified Unison.Util.SyntaxText as SyntaxText
import Unison.Reference ( Reference )
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import Data.Proxy ( Proxy(..) )
type SyntaxText = AnnotatedText Element
instance ToJSON Element
deriving instance ToSchema Element
instance ToJSON a => ToJSON (Segment a)
deriving instance ToSchema a => ToSchema (Segment a)
instance ToJSON SeqOp
deriving instance ToSchema SeqOp
instance ToJSON SyntaxText
deriving instance ToSchema SyntaxText
instance ToSchema r => ToSchema (Seq r) where
declareNamedSchema _ = declareNamedSchema (Proxy @[r])
convertElement :: SyntaxText.Element Reference -> Element
convertElement = \case
SyntaxText.NumericLiteral -> NumericLiteral
SyntaxText.TextLiteral -> TextLiteral
SyntaxText.BytesLiteral -> BytesLiteral
SyntaxText.CharLiteral -> CharLiteral
SyntaxText.BooleanLiteral -> BooleanLiteral
SyntaxText.Blank -> Blank
SyntaxText.Var -> Var
SyntaxText.Referent r -> TermReference $ Referent.toText r
SyntaxText.Reference r -> TypeReference $ Reference.toText r
SyntaxText.Op s -> Op s
SyntaxText.Constructor -> Constructor
SyntaxText.Request -> Request
SyntaxText.AbilityBraces -> AbilityBraces
SyntaxText.ControlKeyword -> ControlKeyword
SyntaxText.TypeOperator -> TypeOperator
SyntaxText.BindingEquals -> BindingEquals
SyntaxText.TypeAscriptionColon -> TypeAscriptionColon
SyntaxText.DataTypeKeyword -> DataTypeKeyword
SyntaxText.DataTypeParams -> DataTypeParams
SyntaxText.Unit -> Unit
SyntaxText.DataTypeModifier -> DataTypeModifier
SyntaxText.UseKeyword -> UseKeyword
SyntaxText.UsePrefix -> UsePrefix
SyntaxText.UseSuffix -> UseSuffix
SyntaxText.HashQualifier n -> HashQualifier (HashQualified.toText n)
SyntaxText.DelayForceChar -> DelayForceChar
SyntaxText.DelimiterChar -> DelimiterChar
SyntaxText.Parenthesis -> Parenthesis
SyntaxText.LinkKeyword -> LinkKeyword
SyntaxText.DocDelimiter -> DocDelimiter
SyntaxText.DocKeyword -> DocKeyword
type UnisonHash = Text
type HashQualifiedName = Text
-- The elements of the Unison grammar, for syntax highlighting purposes
data Element = NumericLiteral
| TextLiteral
| BytesLiteral
| CharLiteral
| BooleanLiteral
| Blank
| Var
| TypeReference UnisonHash
| TermReference UnisonHash
| Op SeqOp
| Constructor
| Request
| AbilityBraces
-- let|handle|in|where|match|with|cases|->|if|then|else|and|or
| ControlKeyword
-- forall|->
| TypeOperator
| BindingEquals
| TypeAscriptionColon
-- type|ability
| DataTypeKeyword
| DataTypeParams
| Unit
-- unique
| DataTypeModifier
-- `use Foo bar` is keyword, prefix, suffix
| UseKeyword
| UsePrefix
| UseSuffix
| HashQualifier HashQualifiedName
| DelayForceChar
-- ? , ` [ ] @ |
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
-- out characters emitted by Pretty.hs helpers like Pretty.commas.
| DelimiterChar
-- ! '
| Parenthesis
| LinkKeyword -- `typeLink` and `termLink`
-- [: :] @[]
| DocDelimiter
-- the 'include' in @[include], etc
| DocKeyword
deriving (Eq, Ord, Show, Generic)
syntax :: Element -> SyntaxText -> SyntaxText
syntax = annotate
-- Convert a `SyntaxText` to a `String`, ignoring syntax markup
toPlain :: SyntaxText -> String
toPlain (AnnotatedText at) = join (toList $ segment <$> at)

121
parser-typechecker/src/Unison/Server/Types.hs Normal file
View File

@ -0,0 +1,121 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.Types where
-- Types common to endpoints --
import Unison.Prelude
import Data.Aeson ( ToJSON
, ToJSONKey
)
import qualified Data.ByteString.Lazy as LZ
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import Data.OpenApi ( ToSchema(..)
, ToParamSchema(..)
)
import Servant.API ( FromHttpApiData )
import qualified Unison.HashQualified as HQ
import Unison.ConstructorType ( ConstructorType )
import Unison.Name ( Name )
import Unison.ShortHash ( ShortHash )
import Unison.Codebase.ShortBranchHash
( ShortBranchHash(..) )
import Unison.Util.Pretty ( Width
, render
)
import Unison.Var ( Var )
import qualified Unison.PrettyPrintEnv as PPE
import Unison.Type ( Type )
import qualified Unison.TypePrinter as TypePrinter
import Unison.Codebase.Editor.DisplayObject
( DisplayObject )
import Unison.Server.Syntax ( SyntaxText )
import qualified Unison.Server.Syntax as Syntax
type HashQualifiedName = Text
type Size = Int
type UnisonName = Text
type UnisonHash = Text
instance ToJSON Name
deriving instance ToSchema Name
deriving via Text instance FromHttpApiData ShortBranchHash
deriving instance ToParamSchema ShortBranchHash
instance ToJSON a => ToJSON (DisplayObject a)
deriving instance ToSchema a => ToSchema (DisplayObject a)
instance ToJSON ShortHash
instance ToJSONKey ShortHash
deriving instance ToSchema ShortHash
instance ToJSON n => ToJSON (HQ.HashQualified n)
deriving instance ToSchema n => ToSchema (HQ.HashQualified n)
instance ToJSON ConstructorType
deriving instance ToSchema ConstructorType
instance ToJSON TypeDefinition
deriving instance ToSchema TypeDefinition
instance ToJSON TermDefinition
deriving instance ToSchema TermDefinition
instance ToJSON DefinitionDisplayResults
deriving instance ToSchema DefinitionDisplayResults
data TermDefinition = TermDefinition
{ termNames :: [HashQualifiedName]
, bestTermName :: HashQualifiedName
, termDefinition :: DisplayObject SyntaxText
, signature :: SyntaxText
} deriving (Eq, Show, Generic)
data TypeDefinition = TypeDefinition
{ typeNames :: [HashQualifiedName]
, bestTypeName :: HashQualifiedName
, typeDefinition :: DisplayObject SyntaxText
} deriving (Eq, Show, Generic)
data DefinitionDisplayResults =
DefinitionDisplayResults
{ termDefinitions :: Map UnisonHash TermDefinition
, typeDefinitions :: Map UnisonHash TypeDefinition
, missingDefinitions :: [HashQualifiedName]
} deriving (Eq, Show, Generic)
formatType :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
formatType ppe w =
fmap Syntax.convertElement . render w . TypePrinter.pretty0 ppe mempty (-1)
munge :: Text -> LZ.ByteString
munge = Text.encodeUtf8 . Text.fromStrict
mungeShow :: Show s => s -> LZ.ByteString
mungeShow = mungeString . show
mungeString :: String -> LZ.ByteString
mungeString = Text.encodeUtf8 . Text.pack
defaultWidth :: Width
defaultWidth = 80
discard :: Applicative m => a -> m ()
discard = const $ pure ()
mayDefault :: Maybe Width -> Width
mayDefault = fromMaybe defaultWidth

59
parser-typechecker/src/Unison/TermParser.hs
View File

@ -123,16 +123,18 @@ blockTerm = lam term <|> infixAppOrBooleanOp
match :: Var v => TermP v
match = do
start <- openBlockWith "match"
start <- openBlockWith "match"
scrutinee <- term
_ <- closeBlock
_ <- P.try (openBlockWith "with") <|> do
t <- anyToken
P.customFailure (ExpectedBlockOpen "with" t)
_ <- closeBlock
_ <- P.try (openBlockWith "with") <|> do
t <- anyToken
P.customFailure (ExpectedBlockOpen "with" t)
(_arities, cases) <- unzip <$> sepBy1 semi matchCase
-- TODO: Add error for empty match list
when (null cases) $ P.customFailure EmptyMatch
_ <- closeBlock
pure $ Term.match (ann start <> ann (last cases)) scrutinee cases
pure $ Term.match (ann start <> maybe (ann start) ann (lastMay cases))
scrutinee
cases
-- Returns the arity of the pattern and the `MatchCase`. Examples:
--
@ -287,27 +289,28 @@ checkCasesArities cases = go Nothing cases where
else P.customFailure $ PatternArityMismatch i j (ann a)
lamCase = do
start <- openBlockWith "cases"
cases <- sepBy1 semi matchCase
start <- openBlockWith "cases"
cases <- sepBy1 semi matchCase
(arity, cases) <- checkCasesArities cases
-- TODO: Add error for empty match list
_ <- closeBlock
when (null cases) (P.customFailure EmptyMatch)
_ <- closeBlock
lamvars <- replicateM arity (Parser.uniqueName 10)
let vars = Var.named <$> [ tweak v i | (v,i) <- lamvars `zip` [(1::Int)..] ]
let vars =
Var.named <$> [ tweak v i | (v, i) <- lamvars `zip` [(1 :: Int) ..] ]
tweak v 0 = v
tweak v i = v <> Text.pack (show i)
lamvarTerms = Term.var (ann start) <$> vars
lamvarTerm = case lamvarTerms of
lamvarTerm = case lamvarTerms of
[e] -> e
es -> DD.tupleTerm es
matchTerm = Term.match (ann start <> ann (last cases)) lamvarTerm cases
pure $ Term.lam' (ann start <> ann (last cases)) vars matchTerm
es -> DD.tupleTerm es
anns = ann start <> maybe (ann start) ann (lastMay cases)
matchTerm = Term.match anns lamvarTerm cases
pure $ Term.lam' anns vars matchTerm
ifthen = label "if" $ do
start <- peekAny
c <- block "if"
t <- block "then"
f <- block "else"
c <- block "if"
t <- block "then"
f <- block "else"
pure $ Term.iff (ann start <> ann f) c t f
text :: Var v => TermP v
@ -320,8 +323,8 @@ boolean :: Var v => TermP v
boolean = ((\t -> Term.boolean (ann t) True) <$> reserved "true") <|>
((\t -> Term.boolean (ann t) False) <$> reserved "false")
seq :: Var v => TermP v -> TermP v
seq = Parser.seq Term.seq
list :: Var v => TermP v -> TermP v
list = Parser.seq Term.list
hashQualifiedPrefixTerm :: Var v => TermP v
hashQualifiedPrefixTerm = resolveHashQualified =<< hqPrefixId
@ -332,7 +335,7 @@ hashQualifiedInfixTerm = resolveHashQualified =<< hqInfixId
-- If the hash qualified is name only, it is treated as a var, if it
-- has a short hash, we resolve that short hash immediately and fail
-- committed if that short hash can't be found in the current environment
resolveHashQualified :: Var v => L.Token HQ.HashQualified -> TermP v
resolveHashQualified :: Var v => L.Token (HQ.HashQualified Name) -> TermP v
resolveHashQualified tok = do
names <- asks names
case L.payload tok of
@ -354,7 +357,7 @@ termLeaf =
, link
, tupleOrParenthesizedTerm
, keywordBlock
, seq term
, list term
, delayQuote
, bang
, docBlock
@ -366,7 +369,7 @@ docBlock = do
segs <- many segment
closeTok <- closeBlock
let a = ann openTok <> ann closeTok
pure . docNormalize $ Term.app a (Term.constructor a DD.docRef DD.docJoinId) (Term.seq a segs)
pure . docNormalize $ Term.app a (Term.constructor a DD.docRef DD.docJoinId) (Term.list a segs)
where
segment = blob <|> linky
blob = do
@ -456,7 +459,7 @@ docNormalize :: (Ord v, Show v) => Term v a -> Term v a
docNormalize tm = case tm of
-- This pattern is just `DD.DocJoin seqs`, but exploded in order to grab
-- the annotations. The aim is just to map `normalize` over it.
a@(Term.App' c@(Term.Constructor' DD.DocRef DD.DocJoinId) s@(Term.Sequence' seqs))
a@(Term.App' c@(Term.Constructor' DD.DocRef DD.DocJoinId) s@(Term.List' seqs))
-> join (ABT.annotation a)
(ABT.annotation c)
(ABT.annotation s)
@ -654,7 +657,7 @@ docNormalize tm = case tm of
blob aa ac at txt =
Term.app aa (Term.constructor ac DD.docRef DD.docBlobId) (Term.text at txt)
join aa ac as segs =
Term.app aa (Term.constructor ac DD.docRef DD.docJoinId) (Term.seq' as segs)
Term.app aa (Term.constructor ac DD.docRef DD.docJoinId) (Term.list' as segs)
mapBlob :: Ord v => (Text -> Text) -> Term v a -> Term v a
-- this pattern is just `DD.DocBlob txt` but exploded to capture the annotations as well
mapBlob f (aa@(Term.App' ac@(Term.Constructor' DD.DocRef DD.DocBlobId) at@(Term.Text' txt)))
@ -910,7 +913,7 @@ bytes = do
b <- bytesToken
let a = ann b
pure $ Term.app a (Term.builtin a "Bytes.fromList")
(Term.seq a $ Term.nat a . fromIntegral <$> Bytes.toWord8s (L.payload b))
(Term.list a $ Term.nat a . fromIntegral <$> Bytes.toWord8s (L.payload b))
number'
:: Ord v

43
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -47,11 +47,13 @@ import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm')
import qualified Unison.ConstructorType as CT
pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty env tm = PP.syntaxToColor $ pretty0 env (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate env tm)
pretty env = PP.syntaxToColor . pretty0 env emptyAc . printAnnotate env
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> Term v a -> ColorText
pretty' (Just width) n t = PP.render width $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
pretty' Nothing n t = PP.renderUnbroken $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
pretty' (Just width) n t =
PP.render width $ PP.syntaxToColor $ pretty0 n emptyAc (printAnnotate n t)
pretty' Nothing n t =
PP.renderUnbroken $ PP.syntaxToColor $ pretty0 n emptyAc (printAnnotate n t)
-- Information about the context in which a term appears, which affects how the
-- term should be rendered.
@ -216,7 +218,7 @@ pretty0
paren (p >= 11) $ (fmt S.DelayForceChar $ l "!") <> pretty0 n (ac 11 Normal im doc) x
LamNamed' v x | (Var.name v) == "()" ->
paren (p >= 11) $ (fmt S.DelayForceChar $ l "'") <> pretty0 n (ac 11 Normal im doc) x
Sequence' xs -> PP.group $
List' xs -> PP.group $
(fmt S.DelimiterChar $ l "[") <> optSpace
<> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace)
(pretty0 n (ac 0 Normal im doc))
@ -516,20 +518,26 @@ a + b = ...
prettyBinding
:: Var v
=> PrettyPrintEnv
-> HQ.HashQualified
-> HQ.HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding n = prettyBinding0 n $ ac (-1) Block Map.empty MaybeDoc
prettyBinding' ::
Var v => Int -> PrettyPrintEnv -> HQ.HashQualified -> Term v a -> ColorText
prettyBinding' width n v t = PP.render width $ PP.syntaxToColor $ prettyBinding n v t
prettyBinding'
:: Var v
=> Int
-> PrettyPrintEnv
-> HQ.HashQualified Name
-> Term v a
-> ColorText
prettyBinding' width n v t =
PP.render width $ PP.syntaxToColor $ prettyBinding n v t
prettyBinding0
:: Var v
=> PrettyPrintEnv
-> AmbientContext
-> HQ.HashQualified
-> HQ.HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding0 env a@AmbientContext { imports = im, docContext = doc } v term = go
@ -632,14 +640,16 @@ paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")"
paren False s = PP.group s
parenIfInfix
:: HQ.HashQualified -> InfixContext -> (Pretty SyntaxText -> Pretty SyntaxText)
:: HQ.HashQualified Name
-> InfixContext
-> (Pretty SyntaxText -> Pretty SyntaxText)
parenIfInfix name ic =
if isSymbolic name && ic == NonInfix then paren True else id
l :: IsString s => String -> Pretty s
l = fromString
isSymbolic :: HQ.HashQualified -> Bool
isSymbolic :: HQ.HashQualified Name -> Bool
isSymbolic (HQ.NameOnly name) = isSymbolic' name
isSymbolic (HQ.HashQualified name _) = isSymbolic' name
isSymbolic (HQ.HashOnly _) = False
@ -653,10 +663,13 @@ isBlank :: String -> Bool
isBlank ('_' : rest) | (isJust ((readMaybe rest) :: Maybe Int)) = True
isBlank _ = False
emptyAc :: AmbientContext
emptyAc = ac (-1) Normal Map.empty MaybeDoc
ac :: Int -> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac prec bc im doc = AmbientContext prec bc NonInfix im doc
fmt :: S.Element -> Pretty S.SyntaxText -> Pretty S.SyntaxText
fmt :: (S.Element r) -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt = PP.withSyntax
{-
@ -815,7 +828,7 @@ suffixCounterTerm n = \case
suffixCounterType :: Var v => PrettyPrintEnv -> Type v a -> PrintAnnotation
suffixCounterType n = \case
Type.Var' v -> countHQ $ HQ.unsafeFromVar v
Type.Ref' r | noImportRefs r || r == Type.vectorRef -> mempty
Type.Ref' r | noImportRefs r || r == Type.listRef -> mempty
Type.Ref' r -> countHQ $ PrettyPrintEnv.typeName n r
_ -> mempty
@ -847,7 +860,7 @@ countPatternUsages n p = Pattern.foldMap' f p where
if noImportRefs r then mempty
else countHQ $ PrettyPrintEnv.patternName n r i
countHQ :: HQ.HashQualified -> PrintAnnotation
countHQ :: HQ.HashQualified Name -> PrintAnnotation
countHQ hq = fold $ fmap countName (HQ.toName $ hq)
countName :: Name -> PrintAnnotation
@ -1183,7 +1196,7 @@ unLamsMatch' t = case unLamsUntilDelay' t of
pattern Bytes' bs <- (toBytes -> Just bs)
toBytes :: Term3 v PrintAnnotation -> Maybe [Word64]
toBytes (App' (Builtin' "Bytes.fromList") (Sequence' bs)) =
toBytes (App' (Builtin' "Bytes.fromList") (List' bs)) =
toList <$> traverse go bs
where go (Nat' n) = Just n
go _ = Nothing

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

@ -67,7 +67,7 @@ type2 = do
tl <- many (effectList <|> valueTypeLeaf)
pure $ foldl' (\a b -> Type.app (ann a <> ann b) a b) hd tl
-- ex : {State Text, IO} (Sequence Int)
-- ex : {State Text, IO} (List Int)
effect :: Var v => TypeP v
effect = do
es <- effectList
@ -87,7 +87,7 @@ sequenceTyp = do
t <- valueType
close <- reserved "]"
let a = ann open <> ann close
pure $ Type.app a (Type.vector a) t
pure $ Type.app a (Type.list a) t
tupleOrParenthesizedType :: Var v => TypeP v -> TypeP v
tupleOrParenthesizedType rec = tupleOrParenthesized rec DD.unitType pair

11
parser-typechecker/src/Unison/TypePrinter.hs
View File

@ -7,6 +7,7 @@ import Unison.Prelude
import qualified Data.Map as Map
import Unison.HashQualified (HashQualified)
import Unison.Name ( Name )
import Unison.NamePrinter (styleHashQualified'')
import Unison.PrettyPrintEnv (PrettyPrintEnv, Imports, elideFQN)
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
@ -132,13 +133,13 @@ prettyRaw n im p tp = go n im p tp
parenNoGroup True s = ( fmt S.Parenthesis "(" ) <> s <> ( fmt S.Parenthesis ")" )
parenNoGroup False s = s
fmt :: S.Element -> Pretty S.SyntaxText -> Pretty S.SyntaxText
fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt = PP.withSyntax
-- todo: provide sample output in comment
prettySignatures'
:: Var v => PrettyPrintEnv
-> [(HashQualified, Type v a)]
-> [(HashQualified Name, Type v a)]
-> [Pretty ColorText]
prettySignatures' env ts = map PP.syntaxToColor $ PP.align
[ ( styleHashQualified'' (fmt $ S.HashQualifier name) name
@ -153,7 +154,7 @@ prettySignatures' env ts = map PP.syntaxToColor $ PP.align
-- todo: provide sample output in comment; different from prettySignatures'
prettySignaturesAlt'
:: Var v => PrettyPrintEnv
-> [([HashQualified], Type v a)]
-> [([HashQualified Name], Type v a)]
-> [Pretty ColorText]
prettySignaturesAlt' env ts = map PP.syntaxToColor $ PP.align
[ ( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names
@ -171,7 +172,7 @@ prettySignaturesAlt' env ts = map PP.syntaxToColor $ PP.align
prettySignatures
:: Var v
=> PrettyPrintEnv
-> [(HashQualified, Type v a)]
-> [(HashQualified Name, Type v a)]
-> Pretty ColorText
prettySignatures env ts = PP.lines $
PP.group <$> prettySignatures' env ts
@ -179,7 +180,7 @@ prettySignatures env ts = PP.lines $
prettySignaturesAlt
:: Var v
=> PrettyPrintEnv
-> [([HashQualified], Type v a)]
-> [([HashQualified Name], Type v a)]
-> Pretty ColorText
prettySignaturesAlt env ts = PP.lines $
PP.group <$> prettySignaturesAlt' env ts

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

@ -831,7 +831,7 @@ vectorConstructorOfArity :: (Var v, Ord loc) => loc -> Int -> M v loc (Type v lo
vectorConstructorOfArity loc arity = do
let elementVar = Var.named "elem"
args = replicate arity (loc, Type.var loc elementVar)
resultType = Type.app loc (Type.vector loc) (Type.var loc elementVar)
resultType = Type.app loc (Type.list loc) (Type.var loc elementVar)
vt = Type.forall loc elementVar (Type.arrows args resultType)
pure vt
@ -912,7 +912,7 @@ synthesize e = scope (InSynthesize e) $
ctx <- getContext
(vs, ft) <- ungeneralize' ft
scope (InFunctionCall vs f ft args) $ synthesizeApps (apply ctx ft) args
go (Term.Sequence' v) = do
go (Term.List' v) = do
ft <- vectorConstructorOfArity (loc e) (Foldable.length v)
case Foldable.toList v of
[] -> pure ft
@ -1095,7 +1095,7 @@ checkPattern scrutineeType0 p =
let vt = existentialp loc v
appendContext [existential v]
-- ['a] <: scrutineeType, where 'a is fresh existential
subtype (Type.app loc (Type.vector loc) vt) scrutineeType
subtype (Type.app loc (Type.list loc) vt) scrutineeType
applyM vt
join <$> traverse (checkPattern vt) ps
Pattern.SequenceOp loc l op r -> do
@ -1104,20 +1104,20 @@ checkPattern scrutineeType0 p =
v <- freshenVar Var.inferOther
let vt = existentialp loc v
appendContext [existential v]
-- todo: `Type.vector loc` is super-probably wrong;
-- todo: `Type.list loc` is super-probably wrong;
-- I'm thinking it should be Ann.Intrinsic, but we don't
-- have access to that here.
subtype (Type.app loc (Type.vector loc) vt) scrutineeType
subtype (Type.app loc (Type.list loc) vt) scrutineeType
applyM vt
case op of
Pattern.Cons -> do
lvs <- checkPattern vt l
-- todo: same `Type.vector loc` thing
rvs <- checkPattern (Type.app locR (Type.vector locR) vt) r
-- todo: same `Type.list loc` thing
rvs <- checkPattern (Type.app locR (Type.list locR) vt) r
pure $ lvs ++ rvs
Pattern.Snoc -> do
-- todo: same `Type.vector loc` thing
lvs <- checkPattern (Type.app locL (Type.vector locL) vt) l
-- todo: same `Type.list loc` thing
lvs <- checkPattern (Type.app locL (Type.list locL) vt) l
rvs <- checkPattern vt r
pure $ lvs ++ rvs
Pattern.Concat ->
@ -1125,11 +1125,11 @@ checkPattern scrutineeType0 p =
(p, _) | isConstLen p -> f
(_, p) | isConstLen p -> f
(_, _) -> lift . failWith $
ConcatPatternWithoutConstantLength loc (Type.app loc (Type.vector loc) vt)
ConcatPatternWithoutConstantLength loc (Type.app loc (Type.list loc) vt)
where
f = liftA2 (++) (g locL l) (g locR r)
-- todo: same `Type.vector loc` thing
g l p = checkPattern (Type.app l (Type.vector l) vt) p
-- todo: same `Type.list loc` thing
g l p = checkPattern (Type.app l (Type.list l) vt) p
-- Only pertains to sequences, returns False if not a sequence
isConstLen :: Pattern loc -> Bool
@ -1738,6 +1738,10 @@ abilityCheck' ambient0 requested0 = go ambient0 requested0 where
Just amb -> do
subtype amb r `orElse` die r
go ambient rs
-- Corner case where a unification caused `r` to expand to a
-- list of effects. This whole function should be restructured
-- such that this can go in a better spot.
Nothing | Type.Effects' es <- r -> go ambient (es ++ rs)
-- 2b. If no:
Nothing -> case r of
-- It's an unsolved existential, instantiate it to all of ambient

78
parser-typechecker/src/Unison/Util/AnnotatedText.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
@ -7,27 +9,29 @@
module Unison.Util.AnnotatedText where
import Unison.Prelude
import qualified Data.List as L
import qualified Data.Foldable as Foldable
import qualified Data.Map as Map
import Data.Sequence (Seq ((:|>), (:<|)))
import qualified Data.Sequence as Seq
import Data.Tuple.Extra (second)
import Unison.Lexer (Line, Pos (..))
import Unison.Util.Monoid (intercalateMap)
import Unison.Util.Range (Range (..), inRange)
import qualified Data.ListLike as LL
import qualified GHC.Exts
-- type AnnotatedText a = AnnotatedText (Maybe a)
data Segment a = Segment { segment :: String, annotation :: Maybe a }
deriving (Eq, Show, Functor, Foldable, Generic)
newtype AnnotatedText a = AnnotatedText (Seq (String, Maybe a))
deriving (Eq, Functor, Foldable, Show)
toPair :: Segment a -> (String, Maybe a)
toPair (Segment s a) = (s, a)
newtype AnnotatedText a = AnnotatedText (Seq (Segment a))
deriving (Eq, Functor, Foldable, Show, Generic)
instance Semigroup (AnnotatedText a) where
AnnotatedText (as :|> ("", _)) <> bs = AnnotatedText as <> bs
as <> AnnotatedText (("", _) :<| bs) = as <> AnnotatedText bs
AnnotatedText (as :|> Segment "" _) <> bs = AnnotatedText as <> bs
as <> AnnotatedText (Segment "" _ :<| bs) = as <> AnnotatedText bs
AnnotatedText as <> AnnotatedText bs = AnnotatedText (as <> bs)
instance Monoid (AnnotatedText a) where
@ -35,43 +39,44 @@ instance Monoid (AnnotatedText a) where
instance LL.FoldableLL (AnnotatedText a) Char where
foldl' f z (AnnotatedText at) = Foldable.foldl' f' z at where
f' z (str, _) = L.foldl' f z str
f' z (Segment str _) = L.foldl' f z str
foldl = LL.foldl
foldr f z (AnnotatedText at) = Foldable.foldr f' z at where
f' (str, _) z = L.foldr f z str
f' (Segment str _) z = L.foldr f z str
instance LL.ListLike (AnnotatedText a) Char where
singleton ch = fromString [ch]
uncons (AnnotatedText at) = case at of
(s,a) :<| tl -> case L.uncons s of
Nothing -> LL.uncons (AnnotatedText tl)
Just (hd,s) -> Just (hd, AnnotatedText $ (s,a) :<| tl)
Segment s a :<| tl -> case L.uncons s of
Nothing -> LL.uncons (AnnotatedText tl)
Just (hd, s) -> Just (hd, AnnotatedText $ Segment s a :<| tl)
Seq.Empty -> Nothing
break f at = (LL.takeWhile (not . f) at, LL.dropWhile (not . f) at)
takeWhile f (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl -> let s' = L.takeWhile f s in
if length s' == length s then
AnnotatedText (pure (s,a)) <> LL.takeWhile f (AnnotatedText tl)
else
AnnotatedText (pure (s',a))
Segment s a :<| tl ->
let s' = L.takeWhile f s
in if length s' == length s
then AnnotatedText (pure $ Segment s a)
<> LL.takeWhile f (AnnotatedText tl)
else AnnotatedText (pure $ Segment s' a)
dropWhile f (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl -> case L.dropWhile f s of
Seq.Empty -> AnnotatedText Seq.Empty
Segment s a :<| tl -> case L.dropWhile f s of
[] -> LL.dropWhile f (AnnotatedText tl)
s -> AnnotatedText $ (s,a) :<| tl
s -> AnnotatedText $ (Segment s a) :<| tl
take n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ pure (take n s, a)
else AnnotatedText (pure (s,a)) <>
LL.take (n - length s) (AnnotatedText tl)
Seq.Empty -> AnnotatedText Seq.Empty
Segment s a :<| tl -> if n <= length s
then AnnotatedText $ pure (Segment (take n s) a)
else AnnotatedText (pure (Segment s a))
<> LL.take (n - length s) (AnnotatedText tl)
drop n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ (drop n s, a) :<| tl
Seq.Empty -> AnnotatedText Seq.Empty
Segment s a :<| tl -> if n <= length s
then AnnotatedText $ (Segment (drop n s) a) :<| tl
else LL.drop (n - length s) (AnnotatedText tl)
null (AnnotatedText at) = all (null . fst) at
null (AnnotatedText at) = all (null . segment) at
-- Quoted text (indented, with source line numbers) with annotated portions.
data AnnotatedExcerpt a = AnnotatedExcerpt
@ -82,7 +87,7 @@ data AnnotatedExcerpt a = AnnotatedExcerpt
annotate' :: Maybe b -> AnnotatedText a -> AnnotatedText b
annotate' a (AnnotatedText at) =
AnnotatedText $ (\(s,_) -> (s, a)) <$> at
AnnotatedText $ (\(Segment s _) -> Segment s a) <$> at
deannotate :: AnnotatedText a -> AnnotatedText b
deannotate = annotate' Nothing
@ -90,13 +95,14 @@ deannotate = annotate' Nothing
-- Replace the annotation (whether existing or no) with the given annotation
annotate :: a -> AnnotatedText a -> AnnotatedText a
annotate a (AnnotatedText at) =
AnnotatedText $ (\(s,_) -> (s,Just a)) <$> at
AnnotatedText $ (\(Segment s _) -> Segment s (Just a)) <$> at
annotateMaybe :: AnnotatedText (Maybe a) -> AnnotatedText a
annotateMaybe (AnnotatedText s) = AnnotatedText (fmap (second join) s)
annotateMaybe (AnnotatedText segments) =
AnnotatedText (fmap (\(Segment s a) -> Segment s (join a)) segments)
trailingNewLine :: AnnotatedText a -> Bool
trailingNewLine (AnnotatedText (init :|> (s,_))) =
trailingNewLine (AnnotatedText (init :|> (Segment s _))) =
case lastMay s of
Just '\n' -> True
Just _ -> False
@ -112,7 +118,7 @@ markup a r = a { annotations = r `Map.union` annotations a }
textLength :: AnnotatedText a -> Int
textLength (AnnotatedText chunks) = foldl' go 0 chunks
where go len (text, _a) = len + length text
where go len (toPair -> (text, _a)) = len + length text
textEmpty :: AnnotatedText a -> Bool
textEmpty = (==0) . textLength
@ -194,7 +200,7 @@ snipWithContext margin source =
else (Just r0, taken, Map.insert r1 a1 rest)
instance IsString (AnnotatedText a) where
fromString s = AnnotatedText . pure $ (s, Nothing)
fromString s = AnnotatedText . pure $ Segment s Nothing
instance IsString (AnnotatedExcerpt a) where
fromString s = AnnotatedExcerpt 1 s mempty
@ -202,4 +208,4 @@ instance IsString (AnnotatedExcerpt a) where
instance GHC.Exts.IsList (AnnotatedText a) where
type Item (AnnotatedText a) = Char
fromList s = fromString s
toList (AnnotatedText s) = join . Foldable.toList $ fmap fst s
toList (AnnotatedText s) = join . Foldable.toList $ fmap segment s

19
parser-typechecker/src/Unison/Util/ColorText.hs
View File

@ -1,3 +1,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.Util.ColorText (
ColorText, Color(..), style, toANSI, toPlain, toHTML, defaultColors,
black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, underline,
@ -7,7 +10,11 @@ where
import Unison.Prelude
import qualified System.Console.ANSI as ANSI
import Unison.Util.AnnotatedText (AnnotatedText(..), annotate)
import Unison.Util.AnnotatedText ( AnnotatedText(..)
, annotate
, Segment(..)
, toPair
)
import qualified Unison.Util.SyntaxText as ST hiding (toPlain)
type ColorText = AnnotatedText Color
@ -43,7 +50,7 @@ style = annotate
toHTML :: String -> ColorText -> String
toHTML cssPrefix (AnnotatedText at) = toList at >>= \case
(s, color) -> wrap color (s >>= newlineToBreak)
Segment s color -> wrap color (s >>= newlineToBreak)
where
newlineToBreak '\n' = "<br/>\n"
newlineToBreak ch = [ch]
@ -54,7 +61,7 @@ toHTML cssPrefix (AnnotatedText at) = toList at >>= \case
-- Convert a `ColorText` to a `String`, ignoring colors
toPlain :: ColorText -> String
toPlain (AnnotatedText at) = join (toList $ fst <$> at)
toPlain (AnnotatedText at) = join (toList $ segment <$> at)
-- Convert a `ColorText` to a `String`, using ANSI codes to produce colors
toANSI :: ColorText -> String
@ -63,9 +70,9 @@ toANSI (AnnotatedText chunks) =
where
go
:: (Maybe Color, Seq String)
-> (String, Maybe Color)
-> Segment Color
-> (Maybe Color, Seq String)
go (prev, r) (text, new) = if prev == new
go (prev, r) (toPair -> (text, new)) = if prev == new
then (prev, r <> pure text)
else
( new
@ -95,7 +102,7 @@ toANSI (AnnotatedText chunks) =
Bold -> [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
Underline -> [ANSI.SetUnderlining ANSI.SingleUnderline]
defaultColors :: ST.Element -> Maybe Color
defaultColors :: ST.Element r -> Maybe Color
defaultColors = \case
ST.NumericLiteral -> Nothing
ST.TextLiteral -> Nothing

11
parser-typechecker/src/Unison/Util/Find.hs
View File

@ -13,11 +13,12 @@ import qualified Data.Text as Text
-- https://www.stackage.org/haddock/lts-13.9/regex-base-0.93.2/Text-Regex-Base-Context.html -- re-exported by TDFA
-- https://www.stackage.org/haddock/lts-13.9/regex-tdfa-1.2.3.1/Text-Regex-TDFA.html
import qualified Text.Regex.TDFA as RE
import Unison.Codebase.SearchResult (SearchResult)
import qualified Unison.Codebase.SearchResult as SR
import Unison.Server.SearchResult (SearchResult)
import qualified Unison.Server.SearchResult as SR
import Unison.HashQualified' (HashQualified)
import qualified Unison.HashQualified' as HQ
import qualified Unison.Name as Name
import Unison.Name ( Name )
import qualified Unison.Names2 as Names
import Unison.Names2 ( Names0 )
import Unison.NamePrinter (prettyHashQualified')
@ -112,7 +113,7 @@ fuzzyFindMatchArray query items render =
-- Ord MatchArray already provides a. and b. todo: c.
prefixFindInBranch ::
Names0 -> HashQualified -> [(SearchResult, P.Pretty P.ColorText)]
Names0 -> HashQualified Name -> [(SearchResult, P.Pretty P.ColorText)]
prefixFindInBranch b hq = fmap getName $
case HQ.toName hq of
-- query string includes a name component, so do a prefix find on that
@ -124,7 +125,7 @@ prefixFindInBranch b hq = fmap getName $
-- only search before the # before the # and after the # after the #
fuzzyFindInBranch :: Names0
-> HashQualified
-> HashQualified Name
-> [(SearchResult, P.Pretty P.ColorText)]
fuzzyFindInBranch b hq =
case HQ.toName hq of
@ -135,7 +136,7 @@ fuzzyFindInBranch b hq =
getName :: SearchResult -> (SearchResult, P.Pretty P.ColorText)
getName sr = (sr, P.syntaxToColor $ prettyHashQualified' (SR.name sr))
candidates :: Names.Names' Name.Name -> HashQualified -> [SearchResult]
candidates :: Names.Names' Name.Name -> HashQualified Name -> [SearchResult]
candidates b hq = typeCandidates <> termCandidates
where
-- filter branch by hash

3
parser-typechecker/src/Unison/Util/Pretty.hs
View File

@ -260,7 +260,8 @@ syntaxToColor :: Pretty ST.SyntaxText -> Pretty ColorText
syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors
-- set the syntax, overriding any present syntax
withSyntax :: ST.Element -> Pretty ST.SyntaxText -> Pretty ST.SyntaxText
withSyntax
:: ST.Element r -> Pretty (ST.SyntaxText' r) -> Pretty (ST.SyntaxText' r)
withSyntax e = fmap $ ST.syntax e
renderUnbroken :: (Monoid s, IsString s) => Pretty s -> s

27
parser-typechecker/src/Unison/Util/SyntaxText.hs
View File

@ -1,25 +1,29 @@
{-# LANGUAGE DeriveGeneric #-}
module Unison.Util.SyntaxText where
import Unison.Prelude
import Unison.Name (Name)
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Referent (Referent')
import Unison.HashQualified (HashQualified)
import Unison.Pattern (SeqOp)
import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate )
import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate, segment)
type SyntaxText = AnnotatedText Element
type SyntaxText = SyntaxText' Reference
type SyntaxText' r = AnnotatedText (Element r)
-- The elements of the Unison grammar, for syntax highlighting purposes
data Element = NumericLiteral
data Element r = NumericLiteral
| TextLiteral
| BytesLiteral
| CharLiteral
| BooleanLiteral
| Blank
| Var
| Reference Reference
| Referent Referent
| Reference r
| Referent (Referent' r)
| Op SeqOp
| Constructor
| Request
@ -40,7 +44,7 @@ data Element = NumericLiteral
| UseKeyword
| UsePrefix
| UseSuffix
| HashQualifier HashQualified
| HashQualifier (HashQualified Name)
| DelayForceChar
-- ? , ` [ ] @ |
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
@ -53,11 +57,12 @@ data Element = NumericLiteral
| DocDelimiter
-- the 'include' in @[include], etc
| DocKeyword
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, Functor)
syntax :: Element -> SyntaxText -> SyntaxText
syntax :: Element r -> SyntaxText' r -> SyntaxText' r
syntax = annotate
-- Convert a `SyntaxText` to a `String`, ignoring syntax markup
toPlain :: SyntaxText -> String
toPlain (AnnotatedText at) = join (toList $ fst <$> at)
toPlain :: SyntaxText' r -> String
toPlain (AnnotatedText at) = join (toList $ segment <$> at)

2
parser-typechecker/tests/Suite.hs
View File

@ -15,7 +15,6 @@ import qualified Unison.Test.Codebase.Path as Path
import qualified Unison.Test.ColorText as ColorText
import qualified Unison.Test.DataDeclaration as DataDeclaration
import qualified Unison.Test.FileParser as FileParser
import qualified Unison.Test.Git as Git
import qualified Unison.Test.Lexer as Lexer
import qualified Unison.Test.IO as TestIO
import qualified Unison.Test.Range as Range
@ -37,6 +36,7 @@ import qualified Unison.Test.Var as Var
import qualified Unison.Test.ANF as ANF
import qualified Unison.Test.MCode as MCode
import qualified Unison.Test.VersionParser as VersionParser
import qualified Unison.Test.Git as Git
test :: Bool -> Test ()
test rt = tests

104
parser-typechecker/tests/Unison/Test/Git.hs
View File

@ -225,65 +225,63 @@ inside.y = c + c
io $ removeDirectoryRecursive tmp
where
gitShouldHave = userShouldHave ++ userShouldNotHave ++
[ ".unison/v1/paths/p8ahoj90hkdjpvlcu60f6ks7q2is1uqbn1e74k5qn4jt1qmrhk0a62e9b2gamm6qmjdii478la2fha5pnnuvhit2b1mp439od7mrqmg.ub"
gitShouldHave = userShouldHave ++ userShouldNotHave
userShouldHave = inside ++ a ++ c ++ x ++ y
userShouldNotHave = b ++ d
inside = -- namespace inside
[ ".unison/v1/paths/kalf383ujq26o2bs9elgbjhhasfs6aka22dpblh530rjd2le1h6207j3t40hc9uihkdddhjrtjsqepilbjt7jgh1uq3fiobh3j1s8n0.ub" ]
a = -- unique type outside.A = A Nat
[ ".unison/v1/types/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/compiled.ub"
, ".unison/v1/dependents/_builtin/Nat/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8"
, ".unison/v1/dependents/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg"
, ".unison/v1/type-index/#d1sq2h5uh94ev9t6eobc2u7mbfpd0so7be8lhj091oge90t4mfsi2052k28j62lhucm32ukrg5f9v57qbalk6h4uva4gj9f732qqdv0/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8#d0"
, ".unison/v1/type-mentions-index/_builtin/Nat/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8#d0"
, ".unison/v1/type-mentions-index/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg#d0"
, ".unison/v1/type-mentions-index/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8#d0"
, ".unison/v1/type-mentions-index/#d1sq2h5uh94ev9t6eobc2u7mbfpd0so7be8lhj091oge90t4mfsi2052k28j62lhucm32ukrg5f9v57qbalk6h4uva4gj9f732qqdv0/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8#d0"
]
userShouldHave =
[ ".unison/v1/type-mentions-index/_builtin/Nat/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
b = -- unique type outside.B = B Nat Nat
[ ".unison/v1/types/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90/compiled.ub"
, ".unison/v1/dependents/_builtin/Nat/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90"
, ".unison/v1/type-index/#4lc2ufmnjmvdhlh94rt8ipit4n84d4hsns0f2nmg4bpiv5r717enq669s6vnc5238oolb2ed4jerlqrc1fneus33p7bbhqom4dsdrb0/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90#d0"
, ".unison/v1/type-mentions-index/_builtin/Nat/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90#d0"
, ".unison/v1/type-mentions-index/#4lc2ufmnjmvdhlh94rt8ipit4n84d4hsns0f2nmg4bpiv5r717enq669s6vnc5238oolb2ed4jerlqrc1fneus33p7bbhqom4dsdrb0/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90#d0"
, ".unison/v1/type-mentions-index/#e3th74omhu8ejhcgq3panjn5iuubjb7d15p64paaro73epa8c4o8mktuicrvglttrna4920n4ub7somkorqdh3msr1vpscp3r5rmjho/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90#d0"
, ".unison/v1/type-mentions-index/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90/#l7h31hucoljkfa4ihprjo6qobpa0jseheqe5qgid19vjf7o2kjm66h709dggri6l4nqkulo2gm3nc107t3o3s2vsphglofum4smut90#d0"
]
c = -- outside.c = 3
[ ".unison/v1/terms/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/compiled.ub"
, ".unison/v1/terms/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/type.ub"
, ".unison/v1/dependents/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/dependents/_builtin/Nat/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo"
, ".unison/v1/type-index/_builtin/Nat/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo"
, ".unison/v1/type-mentions-index/_builtin/Nat/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo"
, ".unison/v1/type-mentions-index/_builtin/Nat/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0#d0"
, ".unison/v1/type-mentions-index/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0#d0"
, ".unison/v1/type-mentions-index/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0#d0"
, ".unison/v1/type-mentions-index/#2po5mnhi28fbs9fecf4ceq4q9htbfcgkl3ljnkhmhq30ec7m5h77fpl1ec96it21690ju6gnhkj8sqr2entn0cu1gfvl8rfddohk6ug/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0#d0"
, ".unison/v1/type-mentions-index/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0#d0"
, ".unison/v1/type-mentions-index/#k1lik85h1sgcpqura4riuipjq3mtkkuu5slida6q2lkg028fd7jn12kufrk2sqrtbftq3snteeh8l9o984mhnurmo3arr5j4d7hg5oo/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0#d0"
, ".unison/v1/types/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0/compiled.ub"
, ".unison/v1/types/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0/compiled.ub"
]
d = -- outside.d = 4
[ ".unison/v1/terms/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg/compiled.ub"
, ".unison/v1/terms/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg/type.ub"
, ".unison/v1/dependents/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
, ".unison/v1/type-index/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
, ".unison/v1/type-mentions-index/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
]
x = -- unique type inside.X = X outside.A
[ ".unison/v1/paths/g22oce42kf9db9oqtaicc5d83pohp9ubqul9c1tsa871a6m7aelke4ja2sslq4d3f46hg1nu1qtlo8sbd0nerl5f295smddiadc8900.ub"
, ".unison/v1/types/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg/compiled.ub"
, ".unison/v1/dependents/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg"
, ".unison/v1/type-index/#rpge3m646i2893acp393dhl1qe9jmvsoe3hpiu3qinrnknf75evuqua3nh4maofvuvn4d3llt418u5ah6sqkok1qc2qvgfrmt92klq8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg#d0"
, ".unison/v1/type-mentions-index/#00k3c9bp6mch2nfkvqsp8td9eoh4mks7m1ae0mmtuv7k93c6tar0o7rn82of1n7hrovtobmfbebee9lmg3mpcn9mpd2admp6pnq0to8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg#d0"
, ".unison/v1/type-mentions-index/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg#d0"
, ".unison/v1/type-mentions-index/#rpge3m646i2893acp393dhl1qe9jmvsoe3hpiu3qinrnknf75evuqua3nh4maofvuvn4d3llt418u5ah6sqkok1qc2qvgfrmt92klq8/#i07oo6cpc7r4jl0kkor6rp8mv9g0tacggs61738v3ti6idvcbc53tb42g4q34dl4eu16thq7mto5otodfdg9es8e4a9f3rijelbk0dg#d0"
]
y = -- inside.y = c + c
[ ".unison/v1/terms/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg/compiled.ub"
, ".unison/v1/terms/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg/type.ub"
, ".unison/v1/dependents/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/dependents/_builtin/Nat.+/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/dependents/_builtin/Nat/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/dependents/_builtin/Nat/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0"
, ".unison/v1/dependents/_builtin/Nat/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo"
, ".unison/v1/dependents/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0"
, ".unison/v1/dependents/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/terms/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg/type.ub"
, ".unison/v1/terms/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg/compiled.ub"
, ".unison/v1/terms/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/type.ub"
, ".unison/v1/terms/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo/compiled.ub"
, ".unison/v1/type-index/_builtin/Nat/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
, ".unison/v1/type-index/_builtin/Nat/#msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo"
, ".unison/v1/type-index/#2po5mnhi28fbs9fecf4ceq4q9htbfcgkl3ljnkhmhq30ec7m5h77fpl1ec96it21690ju6gnhkj8sqr2entn0cu1gfvl8rfddohk6ug/#p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0#d0"
, ".unison/v1/type-index/#k1lik85h1sgcpqura4riuipjq3mtkkuu5slida6q2lkg028fd7jn12kufrk2sqrtbftq3snteeh8l9o984mhnurmo3arr5j4d7hg5oo/#19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0#d0"
, ".unison/v1/paths/esvotl1kr2aqo4tkq7p6lp2chkepmg7n3im1t6hqgd93slk97kops8idp7fj7i57pakvg6lhk0efsco6s2vvtql0jffomm8tvngogd0.ub"
, ".unison/v1/paths/ucnhqspklepn3ihu1o3ph2or9hsrhcpoav93v4gi1v97ttoc2vuup173mcophp8r90r0j3k5mg2knlqr85gdq1dseh8mt5t94c4am4o.ub"
, ".unison/v1/type-mentions-index/_builtin/Nat/#omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg"
]
userShouldNotHave =
[ ".unison/v1/type-mentions-index/_builtin/Nat/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58#d0"
, ".unison/v1/type-mentions-index/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
, ".unison/v1/type-mentions-index/#ap7kd0rc80kp7vjosb0im9j365kgbqhqhj3fv4ufs7bv5b3ed0d4jleqqulu74lj60fuht1oqr117u17jnp1ql8te67vjit95p7k80o/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58#d0"
, ".unison/v1/type-mentions-index/#7krpfrn5gm7m3beiho9jmar3dojnj7mrksnjbmh8i0p9hbmekqv21kqrtsr5lq4rr4n0sako6e7lmt8k2a39senua9efjfo7214s3q8/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58#d0"
, ".unison/v1/type-mentions-index/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58#d0"
, ".unison/v1/types/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58/compiled.ub"
, ".unison/v1/dependents/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
, ".unison/v1/dependents/_builtin/Nat/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58"
, ".unison/v1/terms/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg/type.ub"
, ".unison/v1/terms/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg/compiled.ub"
, ".unison/v1/type-index/_builtin/Nat/#52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg"
, ".unison/v1/type-index/#ap7kd0rc80kp7vjosb0im9j365kgbqhqhj3fv4ufs7bv5b3ed0d4jleqqulu74lj60fuht1oqr117u17jnp1ql8te67vjit95p7k80o/#aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58#d0"
, ".unison/v1/paths/000fqlrbs84nui3o3sp04s32vsbq39iv9foqvs4c38ajki3re86v72s0j5deqtcdqqml9r8e50lcmld2j8ncj7a1fqnqb4pvcaphcu0.ub"
, ".unison/v1/paths/d8ercjm1ol1htu82nmr37ejru1lt7lrl03d5j0u0dp0g2a98nl6n8abdjpf2jkvjuoq4u2qrhn99ps6fiqqn60b0tni7nkp7o593sr0.ub"
, ".unison/v1/paths/bih5ebeug86npp1n0mp51vi7a902ma6m1r3s1ehhfhpc0m71le2fdge8nftte5fuambfo2r753bjnguq5e3p6mip7incmghkho643pg.ub"
]
-- path "[inside]." esvotl1kr2aqo4tkq7p6lp2chkepmg7n3im1t6hqgd93slk97kops8idp7fj7i57pakvg6lhk0efsco6s2vvtql0jffomm8tvngogd0
-- path "[inside].X" ucnhqspklepn3ihu1o3ph2or9hsrhcpoav93v4gi1v97ttoc2vuup173mcophp8r90r0j3k5mg2knlqr85gdq1dseh8mt5t94c4am4o.ub
-- type outside.A #19lkp9i61r793nmuup58b7g3ssmdip8e76ko3n1r0pjk4ld71euh2prdidhnllkt5lsk0tnpn8lv44t7h7q04eeaqvvh75dg4gi77h0
-- type outside.B #aocoefu4taepnvd3gsbtgo5rc6a5oa109e0mfqjfg91m422he1m6nugnq1hb4nedvh32r244v6t0a7jq8k30nt92109466udv78cf58
-- outside.c #msp7bv40rvjd2o8022ti44497ft2hohrg347pu0pfn75vt1s0qh2v8n9ttmmpv23s90fo2v2qpr8o5nl2jelt0cev6pi1sls79kgdoo
-- outside.d #52addbrohuv4kimiv8n6v00vsv46g3pig4imoor34lojgla9bo2tdcumh07pasuo4lmfnab53s1ulj9toai7963spt2jkk5h1qfdnlg
-- type inside.X #p8f8gc2lehvr6ddq6ggittuo3t330q2pkou9gr1408r7o7r33is5cffstl5p916rbui2sa53iqnppsgsuskgodvd5003550roflmvn0
-- inside.y #omqnfettvjqrjmpl2mn7s30g94gogjjoi6hd3ob6394r71mkidbg0kqtgtbkjkmhbqvipqed9ql4b0o7kp68c560e3onb0v3lbv6bjg
-- paths: esvot|ucnhq
-- want: A, c, X, y: 19lkp|msp7b|p8f8g|omqnf
-- no: B, d: aocoe|52add|
-- initialize a fresh codebase
initCodebaseDir :: FilePath -> String -> IO CodebasePath

50
parser-typechecker/transcripts/Transcripts.hs
View File

@ -7,6 +7,7 @@ import EasyTest
import Shellmet (($|))
import System.Directory
import System.FilePath ( (</>)
, splitFileName
, takeExtensions
, takeBaseName
)
@ -17,25 +18,32 @@ import Data.Text ( pack
)
import Data.List
type TestBuilder = FilePath -> FilePath -> String -> Test ()
type TestBuilder = FilePath -> FilePath -> [String] -> String -> Test ()
testBuilder :: FilePath -> FilePath -> String -> Test ()
testBuilder ucm dir transcript = scope transcript $ do
io $ fromString ucm ["transcript", pack (dir </> transcript)]
ok
testBuilderNewRuntime :: FilePath -> FilePath -> String -> Test ()
testBuilderNewRuntime ucm dir transcript = scope transcript $ do
io $ fromString ucm ["--new-runtime", "transcript", pack (dir </> transcript)]
ok
testBuilder' :: FilePath -> FilePath -> String -> Test ()
testBuilder' ucm dir transcript = scope transcript $ do
let input = pack (dir </> transcript)
let output = dir </> takeBaseName transcript <> ".output.md"
io $ runAndCaptureError ucm ["transcript", input] output
testBuilder :: FilePath -> FilePath -> [String] -> String -> Test ()
testBuilder ucm dir prelude transcript = scope transcript $ do
io $ fromString ucm args
ok
where
files = fmap (pack . (dir </>)) (prelude ++ [transcript])
args = ["transcript"] ++ files
testBuilderNewRuntime :: FilePath -> FilePath -> [String] -> String -> Test ()
testBuilderNewRuntime ucm dir prelude transcript = scope transcript $ do
io $ fromString ucm args
ok
where
files = fmap (pack . (dir </>)) (prelude ++ [transcript])
args = ["--new-runtime", "transcript"] ++ files
testBuilder' :: FilePath -> FilePath -> [String] -> String -> Test ()
testBuilder' ucm dir prelude transcript = scope transcript $ do
let output = dir </> takeBaseName transcript <> ".output.md"
io $ runAndCaptureError ucm args output
ok
where
files = fmap (pack . (dir </>)) (prelude ++ [transcript])
args = ["transcript"] ++ files
-- Given a command and arguments, run it and capture the standard error to a file
-- regardless of success or failure.
runAndCaptureError :: FilePath -> [Text] -> FilePath -> IO ()
@ -58,9 +66,15 @@ buildTests testBuilder dir = do
, "Searching for transcripts to run in: " ++ dir
]
files <- io $ listDirectory dir
let transcripts = sort . filter (\f -> takeExtensions f == ".md") $ files
let
-- Any files that start with _ are treated as prelude
(prelude, transcripts) =
partition ((isPrefixOf "_") . snd . splitFileName)
. sort
. filter (\f -> takeExtensions f == ".md") $ files
ucm <- io $ unpack <$> "stack" $| ["exec", "--", "which", "unison"] -- todo: what is it in windows?
tests (testBuilder ucm dir <$> transcripts)
tests (testBuilder ucm dir prelude <$> transcripts)
-- Transcripts that exit successfully get cleaned-up by the transcript parser.
-- Any remaining folders matching "transcript-.*" are output directories

33
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -67,7 +67,7 @@ library
Unison.Codebase.CodeLookup
Unison.Codebase.Editor.AuthorInfo
Unison.Codebase.Editor.Command
Unison.Codebase.Editor.DisplayThing
Unison.Codebase.Editor.DisplayObject
Unison.Codebase.Editor.Git
Unison.Codebase.Editor.HandleInput
Unison.Codebase.Editor.HandleCommand
@ -76,7 +76,6 @@ library
Unison.Codebase.Editor.Output.BranchDiff
Unison.Codebase.Editor.Propagate
Unison.Codebase.Editor.RemoteRepo
Unison.Codebase.Editor.SearchResult'
Unison.Codebase.Editor.SlurpResult
Unison.Codebase.Editor.SlurpComponent
Unison.Codebase.Editor.TodoOutput
@ -93,7 +92,6 @@ library
Unison.Codebase.Patch
Unison.Codebase.Reflog
Unison.Codebase.Runtime
Unison.Codebase.SearchResult
Unison.Codebase.Serialization
Unison.Codebase.Serialization.PutT
Unison.Codebase.Serialization.V1
@ -146,6 +144,16 @@ library
Unison.Runtime.Vector
Unison.Runtime.SparseVector
Unison.Runtime.Stack
Unison.Server.Backend
Unison.Server.CodebaseServer
Unison.Server.Endpoints.GetDefinitions
Unison.Server.Endpoints.ListNamespace
Unison.Server.Errors
Unison.Server.QueryResult
Unison.Server.SearchResult
Unison.Server.SearchResult'
Unison.Server.Syntax
Unison.Server.Types
Unison.TermParser
Unison.TermPrinter
Unison.TypeParser
@ -182,10 +190,12 @@ library
Unison.Util.CyclicOrd
build-depends:
aeson,
ansi-terminal,
async,
base,
base16 >= 0.2.1.0,
base64-bytestring,
basement,
bifunctors,
bytes,
@ -214,6 +224,7 @@ library
hashable,
hashtables,
haskeline,
http-types,
io-streams,
lens,
ListLike,
@ -227,14 +238,19 @@ library
network,
network-simple,
nonempty-containers,
openapi3,
pem,
process,
primitive,
random,
random >= 1.2.0,
raw-strings-qq,
regex-base,
regex-tdfa,
safe,
servant,
servant-docs,
servant-openapi3,
servant-server,
shellmet,
split,
stm,
@ -249,9 +265,13 @@ library
transformers,
unison-core1,
unliftio,
unliftio-core,
util,
unicode-show,
validation,
vector,
wai,
warp,
unicode-show,
x509,
x509-store,
@ -281,6 +301,7 @@ executable unison
Version
build-depends:
base,
bytestring,
containers,
configurator,
directory,
@ -293,7 +314,8 @@ executable unison
temporary,
text,
unison-core1,
unison-parser-typechecker
unison-parser-typechecker,
uri-encode
if !os(windows)
build-depends:
unix
@ -397,6 +419,7 @@ executable transcripts
unison-parser-typechecker
benchmark runtime
import: unison-common
type: exitcode-stdio-1.0
main-is: Main.hs
ghc-options: -O2

11
parser-typechecker/unison/Main.hs
View File

@ -9,8 +9,12 @@ import Unison.Prelude
import Control.Concurrent ( mkWeakThreadId, myThreadId )
import Control.Error.Safe (rightMay)
import Control.Exception ( throwTo, AsyncException(UserInterrupt) )
import Data.ByteString.Char8 ( unpack )
import Data.Configurator.Types ( Config )
import System.Directory ( getCurrentDirectory, removeDirectoryRecursive )
import qualified Network.URI.Encode as URI
import System.Directory ( getCurrentDirectory
, removeDirectoryRecursive
)
import System.Environment ( getArgs, getProgName )
import System.Mem.Weak ( deRefWeak )
import qualified Unison.Codebase.Editor.VersionParser as VP
@ -24,6 +28,7 @@ import qualified Unison.Runtime.Rt1IO as Rt1
import qualified Unison.Runtime.Interface as RTI
import Unison.Symbol ( Symbol )
import qualified Unison.Codebase.Path as Path
import qualified Unison.Server.CodebaseServer as Server
import qualified Version
import qualified Unison.Codebase.TranscriptParser as TR
import qualified System.Path as Path
@ -146,6 +151,10 @@ main = do
case restargs of
[] -> do
(closeCodebase, theCodebase) <- SqliteCodebase.getCodebaseOrExit mcodepath
Server.start theCodebase $ \token port -> do
PT.putPrettyLn . P.string $ "I've started a codebase API server at "
PT.putPrettyLn . P.string $ "http://127.0.0.1:"
<> show port <> "?" <> URI.encode (unpack token)
launch currentDir mNewRun config theCodebase []
closeCodebase
[version] | isFlag "version" version ->

19
stack.yaml
View File

@ -4,12 +4,15 @@ allow-newer: true # async package has needlessly strict upper bound
allow-different-user: true
build:
interleaved-output: false
packages:
- yaks/easytest
- parser-typechecker
- unison-core
- codebase-convert-1to2
# - codebase-convert-1to2
- codebase1/codebase
- codebase2/codebase
- codebase2/codebase-sqlite
@ -33,15 +36,24 @@ extra-deps:
commit: 2944b11d19ee034c48276edc991736105c9d6143
- github: unisonweb/megaparsec
commit: c4463124c578e8d1074c04518779b5ce5957af6b
- github: biocad/openapi3
commit: bd9df532f2381c4b22fe86ef722715088f5cfa68
- github: biocad/servant-openapi3
commit: deb32b7ce166aa86092f7e46ed2cd3cf43d540a4
- base16-0.3.0.1@sha256:22e62f1283adb1fbc81de95f404b0c4039e69e90d92dac8c1bfca0d04941a749,2303
- concurrent-supply-0.1.8@sha256:9373f4868ad28936a7b93781b214ef4afdeacf377ef4ac729583073491c9f9fb,1627
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
- prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163
- sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
- strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617
- aeson-deriving-0.1.1.1@sha256:0b2b6dfdfdf57bb6b3db5978a9e60ba6345b7d48fa254cddb2c76da7d96f8c26,2714
- servant-0.18@sha256:2b5c81089540c208b1945b5ca0c3551c862138d71b224a39fa275a62852a5c75,5068
- servant-server-0.18
- servant-docs-0.11.6
- sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
- direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
- ListLike-4.7.3
- random-1.2.0
# remove these when stackage upgrades containers
- containers-0.6.4.1
- text-1.2.4.1
@ -52,4 +64,7 @@ extra-deps:
ghc-options:
# All packages
"$locals": -haddock -Wall -Wno-name-shadowing -Werror -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms #-freverse-errors
"$locals": -Wall -Wno-name-shadowing -Werror -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms #-freverse-errors
# See https://github.com/haskell/haskell-language-server/issues/208
"$everything": -haddock

5
unison-core/src/Unison/ConstructorType.hs
View File

@ -1,8 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
module Unison.ConstructorType where
import Unison.Prelude
import Unison.Hashable (Hashable, Token(Tag), tokens)
data ConstructorType = Data | Effect deriving (Eq, Ord, Show, Enum)
data ConstructorType = Data | Effect deriving (Eq, Ord, Show, Enum, Generic)
instance Hashable ConstructorType where
tokens b = [Tag . fromIntegral $ fromEnum b]

55
unison-core/src/Unison/HashQualified'.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.HashQualified' where
@ -17,110 +18,108 @@ import Unison.ShortHash ( ShortHash )
import qualified Unison.ShortHash as SH
import qualified Unison.HashQualified as HQ
data HashQualified' n = NameOnly n | HashQualified n ShortHash
deriving (Eq, Functor)
data HashQualified n = NameOnly n | HashQualified n ShortHash
deriving (Eq, Functor, Generic)
type HQSegment = HashQualified' NameSegment
type HQSegment = HashQualified NameSegment
type HashQualified = HashQualified' Name
toHQ :: HashQualified' n -> HQ.HashQualified' n
toHQ :: HashQualified n -> HQ.HashQualified n
toHQ = \case
NameOnly n -> HQ.NameOnly n
HashQualified n sh -> HQ.HashQualified n sh
fromHQ :: HQ.HashQualified' n -> Maybe (HashQualified' n)
fromHQ :: HQ.HashQualified n -> Maybe (HashQualified n)
fromHQ = \case
HQ.NameOnly n -> Just $ NameOnly n
HQ.HashQualified n sh -> Just $ HashQualified n sh
HQ.HashOnly{} -> Nothing
-- Like fromHQ, but turns hashes into hash-qualified empty names
fromHQ' :: Monoid n => HQ.HashQualified' n -> HashQualified' n
fromHQ' :: Monoid n => HQ.HashQualified n -> HashQualified n
fromHQ' = \case
HQ.NameOnly n -> NameOnly n
HQ.HashQualified n sh -> HashQualified n sh
HQ.HashOnly h -> HashQualified mempty h
toName :: HashQualified' n -> n
toName :: HashQualified n -> n
toName = \case
NameOnly name -> name
HashQualified name _ -> name
nameLength :: HashQualified' Name -> Int
nameLength :: HashQualified Name -> Int
nameLength = Text.length . toText
take :: Int -> HashQualified' n -> HashQualified' n
take :: Int -> HashQualified n -> HashQualified n
take i = \case
n@(NameOnly _) -> n
HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.take i s)
toNameOnly :: HashQualified' n -> HashQualified' n
toNameOnly :: HashQualified n -> HashQualified n
toNameOnly = fromName . toName
toHash :: HashQualified' n -> Maybe ShortHash
toHash :: HashQualified n -> Maybe ShortHash
toHash = \case
NameOnly _ -> Nothing
HashQualified _ sh -> Just sh
toString :: Show n => HashQualified' n -> String
toString :: Show n => HashQualified n -> String
toString = Text.unpack . toText
-- Parses possibly-hash-qualified into structured type.
fromText :: Text -> Maybe HashQualified
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of
(name, "" ) ->
Just $ NameOnly (Name.unsafeFromText name) -- safe bc breakOn #
(name, hash) ->
HashQualified (Name.unsafeFromText name) <$> SH.fromText hash
unsafeFromText :: Text -> HashQualified
unsafeFromText :: Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg (fromText txt) where
msg = error ("HashQualified'.unsafeFromText " <> show txt)
msg = error ("HashQualified.unsafeFromText " <> show txt)
fromString :: String -> Maybe HashQualified
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
toText :: Show n => HashQualified' n -> Text
toText :: Show n => HashQualified n -> Text
toText = \case
NameOnly name -> Text.pack (show name)
HashQualified name hash -> Text.pack (show name) <> SH.toText hash
-- Returns the full referent in the hash. Use HQ.take to just get a prefix
fromNamedReferent :: n -> Referent -> HashQualified' n
fromNamedReferent :: n -> Referent -> HashQualified n
fromNamedReferent n r = HashQualified n (Referent.toShortHash r)
-- Returns the full reference in the hash. Use HQ.take to just get a prefix
fromNamedReference :: n -> Reference -> HashQualified' n
fromNamedReference :: n -> Reference -> HashQualified n
fromNamedReference n r = HashQualified n (Reference.toShortHash r)
fromName :: n -> HashQualified' n
fromName :: n -> HashQualified n
fromName = NameOnly
matchesNamedReferent :: Eq n => n -> Referent -> HashQualified' n -> Bool
matchesNamedReferent :: Eq n => n -> Referent -> HashQualified n -> Bool
matchesNamedReferent n r = \case
NameOnly n' -> n' == n
HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Referent.toShortHash r
matchesNamedReference :: Eq n => n -> Reference -> HashQualified' n -> Bool
matchesNamedReference :: Eq n => n -> Reference -> HashQualified n -> Bool
matchesNamedReference n r = \case
NameOnly n' -> n' == n
HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Reference.toShortHash r
-- Use `requalify hq . Referent.Ref` if you want to pass in a `Reference`.
requalify :: HashQualified -> Referent -> HashQualified
requalify :: HashQualified Name -> Referent -> HashQualified Name
requalify hq r = case hq of
NameOnly n -> fromNamedReferent n r
HashQualified n _ -> fromNamedReferent n r
instance Ord n => Ord (HashQualified' n) where
instance Ord n => Ord (HashQualified n) where
compare a b = case compare (toName a) (toName b) of
EQ -> compare (toHash a) (toHash b)
o -> o
instance IsString HashQualified where
instance IsString (HashQualified Name) where
fromString = unsafeFromText . Text.pack
instance Show n => Show (HashQualified' n) where
instance Show n => Show (HashQualified n) where
show = Text.unpack . toText

61
unison-core/src/Unison/HashQualified.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.HashQualified where
@ -17,13 +18,11 @@ import qualified Unison.ShortHash as SH
import Unison.Var ( Var )
import qualified Unison.Var as Var
data HashQualified' n
data HashQualified n
= NameOnly n | HashOnly ShortHash | HashQualified n ShortHash
deriving (Eq, Functor, Show)
deriving (Eq, Functor, Show, Generic)
type HashQualified = HashQualified' Name
stripNamespace :: Text -> HashQualified -> HashQualified
stripNamespace :: Text -> HashQualified Name -> HashQualified Name
stripNamespace namespace hq = case hq of
NameOnly name -> NameOnly $ strip name
HashQualified name sh -> HashQualified (strip name) sh
@ -32,7 +31,7 @@ stripNamespace namespace hq = case hq of
strip name =
fromMaybe name $ Name.stripNamePrefix (Name.unsafeFromText namespace) name
toName :: HashQualified' n -> Maybe n
toName :: HashQualified n -> Maybe n
toName = \case
NameOnly name -> Just name
HashQualified name _ -> Just name
@ -46,25 +45,25 @@ toName = \case
-- [#a29dj2k91, foo.bar.baz] -> [foo.bar.baz, #a29dj2k91]
-- [foo.bar#abc, foo.bar] -> [foo.bar, foo.bar#abc]
-- [.foo.bar, foo.bar] -> [foo.bar, .foo.bar]
sortByLength :: [HashQualified' Name] -> [HashQualified' Name]
sortByLength :: [HashQualified Name] -> [HashQualified Name]
sortByLength hs = sortOn f hs where
f (NameOnly n) = (countDots n, 0, Left n)
f (HashQualified n _h) = (countDots n, 1, Left n)
f (HashOnly h) = (maxBound, 0, Right h)
countDots n = Text.count "." (Text.dropEnd 1 (Name.toText n))
hasName, hasHash :: HashQualified -> Bool
hasName, hasHash :: HashQualified Name -> Bool
hasName = isJust . toName
hasHash = isJust . toHash
toHash :: HashQualified' n -> Maybe ShortHash
toHash :: HashQualified n -> Maybe ShortHash
toHash = \case
NameOnly _ -> Nothing
HashQualified _ sh -> Just sh
HashOnly sh -> Just sh
-- partial: assumes either a name or hash is provided (or both)
fromNameHash :: Maybe Name -> Maybe ShortHash -> HashQualified
fromNameHash :: Maybe Name -> Maybe ShortHash -> HashQualified Name
fromNameHash n h = case n of
Just name -> case h of
Just hash -> HashQualified name hash
@ -73,25 +72,25 @@ fromNameHash n h = case n of
Just hash -> HashOnly hash
Nothing -> error "bad HQ construction"
take :: Int -> HashQualified' n -> HashQualified' n
take :: Int -> HashQualified n -> HashQualified n
take i = \case
n@(NameOnly _) -> n
HashOnly s -> HashOnly (SH.take i s)
HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.take i s)
toString :: Show n => HashQualified' n -> String
toString :: Show n => HashQualified n -> String
toString = Text.unpack . toText
fromString :: String -> Maybe HashQualified
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
unsafeFromString :: String -> HashQualified
unsafeFromString :: String -> HashQualified Name
unsafeFromString s = fromMaybe msg . fromString $ s where
msg = error $ "HashQualified.unsafeFromString " <> show s
-- Parses possibly-hash-qualified into structured type.
-- Doesn't validate against base58 or the codebase.
fromText :: Text -> Maybe HashQualified
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of -- breakOn leaves the '#' on the RHS
(name, "" ) -> Just $ NameOnly (Name.unsafeFromText name) -- safe bc breakOn #
("" , hash) -> HashOnly <$> SH.fromText hash
@ -99,60 +98,60 @@ fromText t = case Text.breakOn "#" t of -- breakOn leaves the '#' on the RHS
-- Won't crash as long as SH.unsafeFromText doesn't crash on any input that
-- starts with '#', which is true as of the time of this writing, but not great.
unsafeFromText :: Text -> HashQualified
unsafeFromText :: Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg . fromText $ txt where
msg = error $ "HashQualified.unsafeFromText " <> show txt
toText :: Show n => HashQualified' n -> Text
toText :: Show n => HashQualified n -> Text
toText = \case
NameOnly name -> Text.pack (show name)
HashQualified name hash -> Text.pack (show name) <> SH.toText hash
HashOnly hash -> SH.toText hash
-- Returns the full referent in the hash. Use HQ.take to just get a prefix
fromNamedReferent :: n -> Referent -> HashQualified' n
fromNamedReferent :: n -> Referent -> HashQualified n
fromNamedReferent n r = HashQualified n (Referent.toShortHash r)
-- Returns the full reference in the hash. Use HQ.take to just get a prefix
fromNamedReference :: n -> Reference -> HashQualified' n
fromNamedReference :: n -> Reference -> HashQualified n
fromNamedReference n r = HashQualified n (Reference.toShortHash r)
fromReferent :: Referent -> HashQualified
fromReferent :: Referent -> HashQualified Name
fromReferent = HashOnly . Referent.toShortHash
fromReference :: Reference -> HashQualified
fromReference :: Reference -> HashQualified Name
fromReference = HashOnly . Reference.toShortHash
fromPattern :: Reference -> Int -> HashQualified
fromPattern :: Reference -> Int -> HashQualified Name
fromPattern r cid = HashOnly $ Referent.patternShortHash r cid
fromName :: n -> HashQualified' n
fromName :: n -> HashQualified n
fromName = NameOnly
unsafeFromVar :: Var v => v -> HashQualified
unsafeFromVar :: Var v => v -> HashQualified Name
unsafeFromVar = unsafeFromText . Var.name
fromVar :: Var v => v -> Maybe HashQualified
fromVar :: Var v => v -> Maybe (HashQualified Name)
fromVar = fromText . Var.name
toVar :: Var v => HashQualified -> v
toVar :: Var v => HashQualified Name -> v
toVar = Var.named . toText
-- todo: find this logic elsewhere and replace with call to this
matchesNamedReferent :: Name -> Referent -> HashQualified -> Bool
matchesNamedReferent :: Name -> Referent -> HashQualified Name -> Bool
matchesNamedReferent n r = \case
NameOnly n' -> n' == n
HashOnly sh -> sh `SH.isPrefixOf` Referent.toShortHash r
HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Referent.toShortHash r
matchesNamedReference :: Name -> Reference -> HashQualified -> Bool
matchesNamedReference :: Name -> Reference -> HashQualified Name -> Bool
matchesNamedReference n r = \case
NameOnly n' -> n' == n
HashOnly sh -> sh `SH.isPrefixOf` Reference.toShortHash r
HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Reference.toShortHash r
-- Use `requalify hq . Referent.Ref` if you want to pass in a `Reference`.
requalify :: HashQualified -> Referent -> HashQualified
requalify :: HashQualified Name -> Referent -> HashQualified Name
requalify hq r = case hq of
NameOnly n -> fromNamedReferent n r
HashQualified n _ -> fromNamedReferent n r
@ -160,10 +159,10 @@ requalify hq r = case hq of
-- this implementation shows HashOnly before the others, because None < Some.
-- Flip it around carefully if HashOnly should come last.
instance Ord n => Ord (HashQualified' n) where
instance Ord n => Ord (HashQualified n) where
compare a b = case compare (toName a) (toName b) of
EQ -> compare (toHash a) (toHash b)
o -> o
--instance Show n => Show (HashQualified' n) where
--instance Show n => Show (HashQualified n) where
-- show = Text.unpack . toText

8
unison-core/src/Unison/Name.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}
@ -47,7 +48,8 @@ import qualified Unison.Var as Var
import qualified Data.RFC5051 as RFC5051
import Data.List ( sortBy, tails )
newtype Name = Name { toText :: Text } deriving (Eq, Ord, Monoid, Semigroup)
newtype Name = Name { toText :: Text }
deriving (Eq, Ord, Monoid, Semigroup, Generic)
sortNames :: [Name] -> [Name]
sortNames = sortNamed id
@ -117,7 +119,7 @@ stripNamePrefix prefix name =
-- a.b.c.d -> d
stripPrefixes :: Name -> Name
stripPrefixes = fromSegment . last . segments
stripPrefixes = maybe "" fromSegment . lastMay . segments
joinDot :: Name -> Name -> Name
joinDot prefix suffix =
@ -149,7 +151,7 @@ suffixes (Name n ) = fmap up . filter (not . null) . tails $ segments' n
where up ns = Name (Text.intercalate "." ns)
unqualified' :: Text -> Text
unqualified' = last . segments'
unqualified' = fromMaybe "" . lastMay . segments'
makeAbsolute :: Name -> Name
makeAbsolute n | toText n == "." = Name ".."

26
unison-core/src/Unison/Names2.hs
View File

@ -70,7 +70,7 @@ data Names' n = Names
, types :: Relation n Reference
} deriving (Eq,Ord)
type Names = Names' HashQualified
type Names = Names' (HashQualified Name)
type Names0 = Names' Name
names0ToNames :: Names0 -> Names
@ -219,7 +219,7 @@ addTerm n r = (<> fromTerms [(n, r)])
--
-- We want to append the hash regardless of whether or not one is a term and the
-- other is a type.
hqName :: Ord n => Names' n -> n -> Either Reference Referent -> HQ.HashQualified' n
hqName :: Ord n => Names' n -> n -> Either Reference Referent -> HQ.HashQualified n
hqName b n = \case
Left r -> if ambiguous then _hqTypeName' b n r else HQ.fromName n
Right r -> if ambiguous then _hqTermName' b n r else HQ.fromName n
@ -228,48 +228,48 @@ hqName b n = \case
-- Conditionally apply hash qualifier to term name.
-- Should be the same as the input name if the Names0 is unconflicted.
hqTermName :: Ord n => Int -> Names' n -> n -> Referent -> HQ.HashQualified' n
hqTermName :: Ord n => Int -> Names' n -> n -> Referent -> HQ.HashQualified n
hqTermName hqLen b n r = if Set.size (termsNamed b n) > 1
then hqTermName' hqLen n r
else HQ.fromName n
hqTypeName :: Ord n => Int -> Names' n -> n -> Reference -> HQ.HashQualified' n
hqTypeName :: Ord n => Int -> Names' n -> n -> Reference -> HQ.HashQualified n
hqTypeName hqLen b n r = if Set.size (typesNamed b n) > 1
then hqTypeName' hqLen n r
else HQ.fromName n
_hqTermName :: Ord n => Names' n -> n -> Referent -> HQ.HashQualified' n
_hqTermName :: Ord n => Names' n -> n -> Referent -> HQ.HashQualified n
_hqTermName b n r = if Set.size (termsNamed b n) > 1
then _hqTermName' b n r
else HQ.fromName n
_hqTypeName :: Ord n => Names' n -> n -> Reference -> HQ.HashQualified' n
_hqTypeName :: Ord n => Names' n -> n -> Reference -> HQ.HashQualified n
_hqTypeName b n r = if Set.size (typesNamed b n) > 1
then _hqTypeName' b n r
else HQ.fromName n
_hqTypeAliases ::
Ord n => Names' n -> n -> Reference -> Set (HQ.HashQualified' n)
Ord n => Names' n -> n -> Reference -> Set (HQ.HashQualified n)
_hqTypeAliases b n r = Set.map (flip (_hqTypeName b) r) (typeAliases b n r)
_hqTermAliases :: Ord n => Names' n -> n -> Referent -> Set (HQ.HashQualified' n)
_hqTermAliases :: Ord n => Names' n -> n -> Referent -> Set (HQ.HashQualified n)
_hqTermAliases b n r = Set.map (flip (_hqTermName b) r) (termAliases b n r)
-- Unconditionally apply hash qualifier long enough to distinguish all the
-- References in this Names0.
hqTermName' :: Int -> n -> Referent -> HQ.HashQualified' n
hqTermName' :: Int -> n -> Referent -> HQ.HashQualified n
hqTermName' hqLen n r =
HQ.take hqLen $ HQ.fromNamedReferent n r
hqTypeName' :: Int -> n -> Reference -> HQ.HashQualified' n
hqTypeName' :: Int -> n -> Reference -> HQ.HashQualified n
hqTypeName' hqLen n r =
HQ.take hqLen $ HQ.fromNamedReference n r
_hqTermName' :: Names' n -> n -> Referent -> HQ.HashQualified' n
_hqTermName' :: Names' n -> n -> Referent -> HQ.HashQualified n
_hqTermName' b n r =
HQ.take (numHashChars b) $ HQ.fromNamedReferent n r
_hqTypeName' :: Names' n -> n -> Reference -> HQ.HashQualified' n
_hqTypeName' :: Names' n -> n -> Reference -> HQ.HashQualified n
_hqTypeName' b n r =
HQ.take (numHashChars b) $ HQ.fromNamedReference n r
@ -288,7 +288,7 @@ filter :: Ord n => (n -> Bool) -> Names' n -> Names' n
filter f (Names terms types) = Names (R.filterDom f terms) (R.filterDom f types)
-- currently used for filtering before a conditional `add`
filterByHQs :: Set HashQualified -> Names0 -> Names0
filterByHQs :: Set (HashQualified Name) -> Names0 -> Names0
filterByHQs hqs Names{..} = Names terms' types' where
terms' = R.filter f terms
types' = R.filter g types

10
unison-core/src/Unison/Names3.hs
View File

@ -123,7 +123,7 @@ makeAbsolute0:: Names0 -> Names0
makeAbsolute0 = map0 Name.makeAbsolute
-- do a prefix match on currentNames and, if no match, then check oldNames.
lookupHQType :: HashQualified -> Names -> Set Reference
lookupHQType :: HashQualified Name -> Names -> Set Reference
lookupHQType hq Names{..} = case hq of
HQ.NameOnly n -> R.lookupDom n (Names.types currentNames)
HQ.HashQualified n sh -> case matches sh currentNames of
@ -143,7 +143,7 @@ hasTermNamed n ns = not (Set.null $ lookupHQTerm (HQ.NameOnly n) ns)
hasTypeNamed :: Name -> Names -> Bool
hasTypeNamed n ns = not (Set.null $ lookupHQType (HQ.NameOnly n) ns)
lookupHQTerm :: HashQualified -> Names -> Set Referent
lookupHQTerm :: HashQualified Name -> Names -> Set Referent
lookupHQTerm hq Names{..} = case hq of
HQ.NameOnly n -> R.lookupDom n (Names.terms currentNames)
HQ.HashQualified n sh -> case matches sh currentNames of
@ -160,7 +160,7 @@ lookupHQTerm hq Names{..} = case hq of
-- If `r` is in "current" names, look up each of its names, and hash-qualify
-- them if they are conflicted names. If `r` isn't in "current" names, look up
-- each of its "old" names and hash-qualify them.
typeName :: Int -> Reference -> Names -> Set HQ'.HashQualified
typeName :: Int -> Reference -> Names -> Set (HQ'.HashQualified Name)
typeName length r Names{..} =
if R.memberRan r . Names.types $ currentNames
then Set.map (\n -> if isConflicted n then hq n else HQ'.fromName n)
@ -169,7 +169,7 @@ typeName length r Names{..} =
where hq n = HQ'.take length (HQ'.fromNamedReference n r)
isConflicted n = R.manyDom n (Names.types currentNames)
termName :: Int -> Referent -> Names -> Set HQ'.HashQualified
termName :: Int -> Referent -> Names -> Set (HQ'.HashQualified Name)
termName length r Names{..} =
if R.memberRan r . Names.terms $ currentNames
then Set.map (\n -> if isConflicted n then hq n else HQ'.fromName n)
@ -183,7 +183,7 @@ termName length r Names{..} =
-- Set HashQualified -> Branch m -> Command m i v Names
-- populate historical names
lookupHQPattern
:: HQ.HashQualified
:: HQ.HashQualified Name
-> CT.ConstructorType
-> Names
-> Set (Reference, Int)

10
unison-core/src/Unison/Paths.hs
View File

@ -96,9 +96,9 @@ focus1 e = ABT.Path go'
)
go Bound (Type (T.ForallNamed' v body)) = Just
(Var v, \v -> Type <$> (T.forall () <$> asVar v <*> pure (wt body)), [])
go (Index i) (Term (E.Sequence' vs)) | i < Sequence.length vs && i >= 0 = Just
go (Index i) (Term (E.List' vs)) | i < Sequence.length vs && i >= 0 = Just
( Term (vs `Sequence.index` i)
, \e -> (\e -> Term $ E.seq' () $ Sequence.update i e (fmap w vs)) <$> asTerm e
, \e -> (\e -> Term $ E.list' () $ Sequence.update i e (fmap w vs)) <$> asTerm e
, []
)
go (Binding i) (Term (E.Let1NamedTop' top v b body)) | i <= 0 = Just
@ -164,9 +164,9 @@ insertTerm at ctx = do
let at' = init at
(parent,set,_) <- focus at' (Term ctx)
case parent of
Term (E.Sequence' vs) -> do
i <- listToMaybe [i | Index i <- [last at]]
let v2 = E.seq'() ((E.vmap ABT.Bound <$> Sequence.take (i+1) vs) `mappend`
Term (E.List' vs) -> do
i <- listToMaybe [i | Index i <- toList (lastMay at)]
let v2 = E.list'() ((E.vmap ABT.Bound <$> Sequence.take (i+1) vs) `mappend`
pure (E.blank ()) `mappend`
(E.vmap ABT.Bound <$> Sequence.drop (i+1) vs))
asTerm =<< set (Term v2)

6
unison-core/src/Unison/Pattern.hs
View File

@ -35,7 +35,7 @@ data Pattern loc
data SeqOp = Cons
| Snoc
| Concat
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord, Generic)
instance H.Hashable SeqOp where
tokens Cons = [H.Tag 0]
@ -147,8 +147,8 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e
EffectPure _ _ -> [effectType Type.effectRef]
EffectBind _ r cid _ _ ->
[effectType Type.effectRef, effectType r, effectConstructor r cid]
SequenceLiteral _ _ -> [literalType Type.vectorRef]
SequenceOp {} -> [literalType Type.vectorRef]
SequenceLiteral _ _ -> [literalType Type.listRef]
SequenceOp {} -> [literalType Type.listRef]
Boolean _ _ -> [literalType Type.booleanRef]
Int _ _ -> [literalType Type.intRef]
Nat _ _ -> [literalType Type.natRef]

12
unison-core/src/Unison/Reference.hs
View File

@ -27,7 +27,8 @@ module Unison.Reference
toId,
toText,
unsafeId,
toShortHash) where
toShortHash,
idToShortHash) where
import Unison.Prelude
@ -40,6 +41,11 @@ import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import Data.Char (isDigit)
-- | Either a builtin or a user defined (hashed) top-level declaration.
--
-- Used for both terms and types. Doesn't distinguish between them.
--
-- Other used defined things like local variables don't get @Reference@s.
data Reference
= Builtin Text.Text
-- `Derived` can be part of a strongly connected component.
@ -53,6 +59,7 @@ pattern Derived h i n = DerivedId (Id h i n)
-- A good idea, but causes a weird problem with view patterns in PatternP.hs in ghc 8.4.3
--{-# COMPLETE Builtin, Derived #-}
-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together.
data Id = Id H.Hash Pos Size deriving (Eq,Ord,Generic)
unsafeId :: Reference -> Id
@ -60,6 +67,9 @@ unsafeId (Builtin b) =
error $ "Tried to get the hash of builtin " <> Text.unpack b <> "."
unsafeId (DerivedId x) = x
idToShortHash :: Id -> ShortHash
idToShortHash = toShortHash . DerivedId
-- todo: move these to ShortHash module?
-- but Show Reference currently depends on SH
toShortHash :: Reference -> ShortHash

8
unison-core/src/Unison/Referent.hs
View File

@ -17,6 +17,10 @@ import qualified Unison.ShortHash as SH
import Unison.ConstructorType (ConstructorType)
import qualified Unison.ConstructorType as CT
-- | Specifies a term.
--
-- Either a term 'Reference', a data constructor, or an effect constructor.
--
-- Slightly odd naming. This is the "referent of term name in the codebase",
-- rather than the target of a Reference.
type Referent = Referent' Reference
@ -26,8 +30,12 @@ pattern Con :: Reference -> Int -> ConstructorType -> Referent
pattern Con r i t = Con' r i t
{-# COMPLETE Ref, Con #-}
-- | Cannot be a builtin.
type Id = Referent' R.Id
-- | When @Ref'@ then @r@ represents a term.
--
-- When @Con'@ then @r@ is a type declaration.
data Referent' r = Ref' r | Con' r Int ConstructorType
deriving (Show, Ord, Eq, Functor)

3
unison-core/src/Unison/ShortHash.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -12,7 +13,7 @@ import qualified Data.Text as Text
data ShortHash
= Builtin Text
| ShortHash { prefix :: Text, cycle :: Maybe Text, cid :: Maybe Text }
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic)
-- currently unused
isConstructor :: ShortHash -> Bool

22
unison-core/src/Unison/Term.hs
View File

@ -72,7 +72,7 @@ data F typeVar typeAnn patternAnn a
| Handle a a
| App a a
| Ann a (Type typeVar typeAnn)
| Sequence (Seq a)
| List (Seq a)
| If a a a
| And a a
| Or a a
@ -246,7 +246,7 @@ extraMap vtf atf apf = \case
Handle x y -> Handle x y
App x y -> App x y
Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x))
Sequence x -> Sequence x
List x -> List x
If x y z -> If x y z
And x y -> And x y
Or x y -> Or x y
@ -434,7 +434,7 @@ pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg))
pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg))
-- end pretty-printer helper patterns
pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t))
pattern Sequence' xs <- (ABT.out -> ABT.Tm (Sequence xs))
pattern List' xs <- (ABT.out -> ABT.Tm (List xs))
pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst))
pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))))
pattern LamsNamed' vs body <- (unLams' -> Just (vs, body))
@ -540,11 +540,11 @@ and a x y = ABT.tm' a (And x y)
or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
or a x y = ABT.tm' a (Or x y)
seq :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
seq a es = seq' a (Sequence.fromList es)
list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
list a es = list' a (Sequence.fromList es)
seq' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
seq' a es = ABT.tm' a (Sequence es)
list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
list' a es = ABT.tm' a (List es)
apps
:: Ord v
@ -881,7 +881,7 @@ generalizedDependencies termRef typeRef literalType dataConstructor dataType eff
f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t
f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t
f t@(Text _) = Writer.tell [literalType Type.textRef] $> t
f t@(Sequence _) = Writer.tell [literalType Type.vectorRef] $> t
f t@(List _) = Writer.tell [literalType Type.listRef] $> t
f t@(Constructor r cid) =
Writer.tell [dataType r, dataConstructor r cid] $> t
f t@(Request r cid) =
@ -1031,7 +1031,7 @@ instance Var v => Hashable1 (F v a p) where
error "handled above, but GHC can't figure this out"
App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)]
Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)]
Sequence as -> tag 5 : varint (Sequence.length as) : map
List as -> tag 5 : varint (Sequence.length as) : map
(hashed . hash)
(toList as)
Lam a -> [tag 6, hashed (hash a)]
@ -1082,7 +1082,7 @@ instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where
Handle h b == Handle h2 b2 = h == h2 && b == b2
App f a == App f2 a2 = f == f2 && a == a2
Ann e t == Ann e2 t2 = e == e2 && t == t2
Sequence v == Sequence v2 = v == v2
List v == List v2 = v == v2
If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2
And a b == And a2 b2 = a == a2 && b == b2
Or a b == Or a2 b2 = a == a2 && b == b2
@ -1105,7 +1105,7 @@ instance (Show v, Show a) => Show (F v a0 p a) where
go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k
go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x
go _ (Lam body ) = showParen True (s "λ " <> shows body)
go _ (Sequence vs ) = showListWith shows (toList vs)
go _ (List vs ) = showListWith shows (toList vs)
go _ (Blank b ) = case b of
B.Blank -> s "_"
B.Recorded (B.Placeholder _ r) -> s ("_" ++ r)

9
unison-core/src/Unison/Type.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
@ -207,14 +206,14 @@ derivedBase32Hex r a = ref a r
-- derivedBase58' :: Text -> Reference
-- derivedBase58' base58 = Reference.derivedBase58 base58 0 1
intRef, natRef, floatRef, booleanRef, textRef, charRef, vectorRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
intRef = Reference.Builtin "Int"
natRef = Reference.Builtin "Nat"
floatRef = Reference.Builtin "Float"
booleanRef = Reference.Builtin "Boolean"
textRef = Reference.Builtin "Text"
charRef = Reference.Builtin "Char"
vectorRef = Reference.Builtin "Sequence"
listRef = Reference.Builtin "Sequence"
bytesRef = Reference.Builtin "Bytes"
effectRef = Reference.Builtin "Effect"
termLinkRef = Reference.Builtin "Link.Term"
@ -301,8 +300,8 @@ builtinIO a = ref a builtinIORef
socket :: Ord v => a -> Type v a
socket a = ref a socketRef
vector :: Ord v => a -> Type v a
vector a = ref a vectorRef
list :: Ord v => a -> Type v a
list a = ref a listRef
bytes :: Ord v => a -> Type v a
bytes a = ref a bytesRef

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

@ -137,7 +137,7 @@ reset :: Var v => v -> v
reset v = typed (typeOf v)
unqualifiedName :: Var v => v -> Text
unqualifiedName = last . Name.segments' . name
unqualifiedName = fromMaybe "" . lastMay . Name.segments' . name
unqualified :: Var v => v -> v
unqualified v = case typeOf v of

44
unison-src/new-runtime-failing-transcripts/mvar.md Normal file
View File

@ -0,0 +1,44 @@
# tests for io2.MVar
`MVar`s are mutable, sharable storage for a single value, which may or
may not be present at any given time. It is sharable in the sense that
it is safe for multiple threads to attempt simultaneous reading and
writing to and from the same MVar safely.
MVars are the building block on which many other concurrency
primitives can be built, such as Futures, Run at most once initializer
blocks, Queues, etc.
```unison
testMvars: '{io2.IO}[Result]
testMvars _ =
test = 'let
test = "test"
test2 = "test2"
ma = MVar.new test
check "ma should not be empty" (not (isEmpty ma))
test' = take ma
expectU "should reap what you sow" test test'
check "ma should be empty" (isEmpty ma)
put ma test
test'' = swap ma test2
expectU "swap returns old contents" test test''
test''' = swap ma test
expectU "swap returns old contents" test2 test'''
ma2 = !MVar.newEmpty
check "tryTake should succeed when not empty" (not (isNone (tryTake ma)))
check "tryTake should not succeed when empty" (isNone (tryTake ma))
check "ma2 should be empty" (isEmpty ma2)
check "tryTake should fail when empty" (isNone (tryTake ma2))
runTest test
```
```ucm
.> add
.> io.test testMvars
```

267
unison-src/new-runtime-transcripts/_base.md Normal file
View File

@ -0,0 +1,267 @@
# Base transcript
## Overview
This transcript is meant to be a transcript which can be run as a
prelude to other transcripts, creating helper functions, and including
a minimal subset of base in order to facilitate write nicer
transcripts which contain less boilerplate.
## Usage
```ucm:hide
.> builtins.merge
.> builtins.mergeio
.> cd builtin
```
```unison:hide
a |> f = f a
compose f g = a -> f (g a)
compose2 f g = a -> b -> f (g a b)
compose3 f g = a -> b -> c -> f (g a b c)
id a = a
ability Exception where
raise: io2.Failure -> anything
Exception.reraise : Either Failure a ->{Exception} a
Exception.reraise = cases
Left e -> Exception.raise e
Right a -> a
Exception.toEither.handler : Request {Exception} a -> Either Failure a
Exception.toEither.handler = cases
{ a } -> Right a
{Exception.raise f -> _} -> Left f
Exception.toEither : '{ε, Exception} a -> {ε} Either Failure a
Exception.toEither a = handle !a with Exception.toEither.handler
ability Throw e where
throw : e -> a
List.all : (a ->{ε} Boolean) -> [a] ->{ε} Boolean
List.all f = cases
[] -> true
h +: t -> f h && all f t
List.map : (a ->{m} b) -> [a] ->{m} [b]
List.map f xs =
go acc = cases
[] -> acc
h +: t -> go (acc :+ f h) t
go [] xs
List.filter: (a -> Boolean) -> [a] -> [a]
List.filter f all =
go acc = cases
[] -> acc
a +: as -> if (f a) then go (cons a acc) as else go acc as
go [] all
check: Text -> Boolean -> {Stream Result} ()
check msg test = if test then emit (Ok msg) else emit (Fail msg)
checks : [Boolean] -> [Result]
checks bs =
if all id bs then [Ok "Passed"]
else [Fail "Failed"]
hex : Bytes -> Text
hex b =
match Bytes.toBase16 b |> fromUtf8.impl
with Left e -> bug e
Right t -> t
ascii : Text -> Bytes
ascii = toUtf8
fromHex : Text -> Bytes
fromHex txt =
match toUtf8 txt |> Bytes.fromBase16
with Left e -> bug e
Right bs -> bs
isNone = cases
Some _ -> false
None -> true
ability Stream a where
emit: a -> ()
Stream.toList.handler : Request {Stream a} r -> [a]
Stream.toList.handler =
go : [a] -> Request {Stream a} r -> [a]
go acc = cases
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
{ _ } -> acc
go []
Stream.toList : '{Stream a} r -> [a]
Stream.toList s = handle !s with toList.handler
Stream.collect.handler : Request {Stream a} r -> ([a],r)
Stream.collect.handler =
go : [a] -> Request {Stream a} r -> ([a],r)
go acc = cases
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
{ r } -> (acc, r)
go []
Stream.collect : '{e, Stream a} r -> {e} ([a],r)
Stream.collect s =
handle !s with Stream.collect.handler
-- An ability that facilitates creating temoporary directories that can be
-- automatically cleaned up
ability TempDirs where
newTempDir: Text -> Text
removeDir: Text -> ()
-- A handler for TempDirs which cleans up temporary directories
-- This will be useful for IO tests which need to interact with
-- the filesystem
autoCleaned.handler: '{io2.IO} (Request {TempDirs} r -> r)
autoCleaned.handler _ =
remover : [Text] -> {io2.IO} ()
remover = cases
a +: as -> match removeDirectory.impl a with
Left (Failure _ e _) -> watch e ()
_ -> ()
remover as
[] -> ()
go : [Text] -> {io2.IO} Request {TempDirs} r -> r
go dirs = cases
{ a } -> remover dirs
a
{ TempDirs.newTempDir prefix -> k } ->
dir = createTempDirectory prefix
handle k dir with go (dir +: dirs)
{ TempDirs.removeDir dir -> k } ->
removeDirectory dir
handle !k with go (filter (d -> not (d == dir)) dirs)
go []
autoCleaned: '{io2.IO, TempDirs} r -> r
autoCleaned comp = handle !comp with !autoCleaned.handler
stdout = IO.stdHandle StdOut
printText : Text -> {io2.IO} Either Failure ()
printText t = putBytes.impl stdout (toUtf8 t)
-- Run tests which might fail, might create temporary directores and Stream out
-- results, returns the Results and the result of the test
evalTest: '{Stream Result, TempDirs, io2.IO, Exception} a ->{io2.IO, Exception}([Result], a)
evalTest a = handle (handle !a with Stream.collect.handler) with !autoCleaned.handler
-- Run tests which might fail, might create temporary directores and Stream out
-- results, but ignore the produced value and only return the test Results
runTest: '{Stream Result, Exception, TempDirs, Exception, io2.IO} a -> {io2.IO}[Result]
runTest t = handle evalTest t with cases
{ Exception.raise (Failure _ f _) -> _ } -> [ Fail ("Error running test: " ++ f) ]
{ (a, _) } -> a
expect : Text -> (a -> a -> Boolean) -> a -> a -> {Stream Result} ()
expect msg compare expected actual = if compare expected actual then emit (Ok msg) else emit (Fail msg)
expectU : Text -> a -> a -> {Stream Result} ()
expectU msg expected actual = expect msg (==) expected actual
startsWith: Text -> Text -> Boolean
startsWith prefix text = (eq (Text.take (size prefix) text) prefix)
contains : Text -> Text -> Boolean
contains needle haystack = if (size haystack) == 0 then false else
if startsWith needle haystack then true else
contains needle (drop 1 haystack)
isDirectory = compose reraise isDirectory.impl
createTempDirectory = compose reraise createTempDirectory.impl
removeDirectory = compose reraise removeDirectory.impl
fileExists = compose reraise fileExists.impl
renameDirectory = compose2 reraise renameDirectory.impl
openFile = compose2 reraise openFile.impl
isFileOpen = compose reraise isFileOpen.impl
closeFile = compose reraise closeFile.impl
isSeekable = compose reraise isSeekable.impl
isFileEOF = compose reraise isFileEOF.impl
Text.fromUtf8 = compose reraise fromUtf8.impl
getBytes = compose2 reraise getBytes.impl
handlePosition = compose reraise handlePosition.impl
seekHandle = compose3 reraise seekHandle.impl
putBytes = compose2 reraise putBytes.impl
systemTime = compose reraise systemTime.impl
decodeCert = compose reraise decodeCert.impl
serverSocket = compose2 reraise serverSocket.impl
listen = compose reraise listen.impl
handshake = compose reraise handshake.impl
send = compose2 reraise send.impl
closeSocket = compose reraise closeSocket.impl
clientSocket = compose2 reraise clientSocket.impl
receive = compose reraise receive.impl
terminate = compose reraise terminate.impl
newServer = compose2 reraise newServer.impl
socketAccept = compose reraise socketAccept.impl
socketPort = compose reraise socketPort.impl
newClient = compose2 reraise newClient.impl
MVar.take = compose reraise take.impl
MVar.put = compose2 reraise put.impl
MVar.swap = compose2 reraise MVar.swap.impl
```
```ucm:hide
.> add
```
The test shows that `hex (fromHex str) == str` as expected.
```unison:hide
test> hex.tests.ex1 = checks let
s = "3984af9b"
[hex (fromHex s) == s]
```
```ucm:hide
.scratch> test
```
Lets do some basic testing of our test harness to make sure its
working.
```unison
testAutoClean : '{io2.IO}[Result]
testAutoClean _ =
go: '{Stream Result, Exception, io2.IO, TempDirs} Text
go _ =
dir = newTempDir "autoclean"
check "our temporary directory should exist" (isDirectory dir)
dir
handle (evalTest go) with cases
{ Exception.raise (Failure _ t _) -> _ } -> [Fail t]
{ (results, dir) } ->
match io2.IO.isDirectory.impl dir with
Right b -> if b
then results :+ (Fail "our temporary directory should no longer exist")
else results :+ (Ok "our temporary directory should no longer exist")
Left (Failure _ t _) -> results :+ (Fail t)
```
```ucm
.> add
.> io.test testAutoClean
```

276
unison-src/new-runtime-transcripts/_base.output.md Normal file
View File

@ -0,0 +1,276 @@
# Base transcript
## Overview
This transcript is meant to be a transcript which can be run as a
prelude to other transcripts, creating helper functions, and including
a minimal subset of base in order to facilitate write nicer
transcripts which contain less boilerplate.
## Usage
```unison
a |> f = f a
compose f g = a -> f (g a)
compose2 f g = a -> b -> f (g a b)
compose3 f g = a -> b -> c -> f (g a b c)
id a = a
ability Exception where
raise: io2.Failure -> anything
Exception.reraise : Either Failure a ->{Exception} a
Exception.reraise = cases
Left e -> Exception.raise e
Right a -> a
Exception.toEither.handler : Request {Exception} a -> Either Failure a
Exception.toEither.handler = cases
{ a } -> Right a
{Exception.raise f -> _} -> Left f
Exception.toEither : '{ε, Exception} a -> {ε} Either Failure a
Exception.toEither a = handle !a with Exception.toEither.handler
ability Throw e where
throw : e -> a
List.all : (a ->{ε} Boolean) -> [a] ->{ε} Boolean
List.all f = cases
[] -> true
h +: t -> f h && all f t
List.map : (a ->{m} b) -> [a] ->{m} [b]
List.map f xs =
go acc = cases
[] -> acc
h +: t -> go (acc :+ f h) t
go [] xs
List.filter: (a -> Boolean) -> [a] -> [a]
List.filter f all =
go acc = cases
[] -> acc
a +: as -> if (f a) then go (cons a acc) as else go acc as
go [] all
check: Text -> Boolean -> {Stream Result} ()
check msg test = if test then emit (Ok msg) else emit (Fail msg)
checks : [Boolean] -> [Result]
checks bs =
if all id bs then [Ok "Passed"]
else [Fail "Failed"]
hex : Bytes -> Text
hex b =
match Bytes.toBase16 b |> fromUtf8.impl
with Left e -> bug e
Right t -> t
ascii : Text -> Bytes
ascii = toUtf8
fromHex : Text -> Bytes
fromHex txt =
match toUtf8 txt |> Bytes.fromBase16
with Left e -> bug e
Right bs -> bs
isNone = cases
Some _ -> false
None -> true
ability Stream a where
emit: a -> ()
Stream.toList.handler : Request {Stream a} r -> [a]
Stream.toList.handler =
go : [a] -> Request {Stream a} r -> [a]
go acc = cases
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
{ _ } -> acc
go []
Stream.toList : '{Stream a} r -> [a]
Stream.toList s = handle !s with toList.handler
Stream.collect.handler : Request {Stream a} r -> ([a],r)
Stream.collect.handler =
go : [a] -> Request {Stream a} r -> ([a],r)
go acc = cases
{ Stream.emit a -> k } -> handle !k with go (acc :+ a)
{ r } -> (acc, r)
go []
Stream.collect : '{e, Stream a} r -> {e} ([a],r)
Stream.collect s =
handle !s with Stream.collect.handler
-- An ability that facilitates creating temoporary directories that can be
-- automatically cleaned up
ability TempDirs where
newTempDir: Text -> Text
removeDir: Text -> ()
-- A handler for TempDirs which cleans up temporary directories
-- This will be useful for IO tests which need to interact with
-- the filesystem
autoCleaned.handler: '{io2.IO} (Request {TempDirs} r -> r)
autoCleaned.handler _ =
remover : [Text] -> {io2.IO} ()
remover = cases
a +: as -> match removeDirectory.impl a with
Left (Failure _ e _) -> watch e ()
_ -> ()
remover as
[] -> ()
go : [Text] -> {io2.IO} Request {TempDirs} r -> r
go dirs = cases
{ a } -> remover dirs
a
{ TempDirs.newTempDir prefix -> k } ->
dir = createTempDirectory prefix
handle k dir with go (dir +: dirs)
{ TempDirs.removeDir dir -> k } ->
removeDirectory dir
handle !k with go (filter (d -> not (d == dir)) dirs)
go []
autoCleaned: '{io2.IO, TempDirs} r -> r
autoCleaned comp = handle !comp with !autoCleaned.handler
stdout = IO.stdHandle StdOut
printText : Text -> {io2.IO} Either Failure ()
printText t = putBytes.impl stdout (toUtf8 t)
-- Run tests which might fail, might create temporary directores and Stream out
-- results, returns the Results and the result of the test
evalTest: '{Stream Result, TempDirs, io2.IO, Exception} a ->{io2.IO, Exception}([Result], a)
evalTest a = handle (handle !a with Stream.collect.handler) with !autoCleaned.handler
-- Run tests which might fail, might create temporary directores and Stream out
-- results, but ignore the produced value and only return the test Results
runTest: '{Stream Result, Exception, TempDirs, Exception, io2.IO} a -> {io2.IO}[Result]
runTest t = handle evalTest t with cases
{ Exception.raise (Failure _ f _) -> _ } -> [ Fail ("Error running test: " ++ f) ]
{ (a, _) } -> a
expect : Text -> (a -> a -> Boolean) -> a -> a -> {Stream Result} ()
expect msg compare expected actual = if compare expected actual then emit (Ok msg) else emit (Fail msg)
expectU : Text -> a -> a -> {Stream Result} ()
expectU msg expected actual = expect msg (==) expected actual
startsWith: Text -> Text -> Boolean
startsWith prefix text = (eq (Text.take (size prefix) text) prefix)
contains : Text -> Text -> Boolean
contains needle haystack = if (size haystack) == 0 then false else
if startsWith needle haystack then true else
contains needle (drop 1 haystack)
isDirectory = compose reraise isDirectory.impl
createTempDirectory = compose reraise createTempDirectory.impl
removeDirectory = compose reraise removeDirectory.impl
fileExists = compose reraise fileExists.impl
renameDirectory = compose2 reraise renameDirectory.impl
openFile = compose2 reraise openFile.impl
isFileOpen = compose reraise isFileOpen.impl
closeFile = compose reraise closeFile.impl
isSeekable = compose reraise isSeekable.impl
isFileEOF = compose reraise isFileEOF.impl
Text.fromUtf8 = compose reraise fromUtf8.impl
getBytes = compose2 reraise getBytes.impl
handlePosition = compose reraise handlePosition.impl
seekHandle = compose3 reraise seekHandle.impl
putBytes = compose2 reraise putBytes.impl
systemTime = compose reraise systemTime.impl
decodeCert = compose reraise decodeCert.impl
serverSocket = compose2 reraise serverSocket.impl
listen = compose reraise listen.impl
handshake = compose reraise handshake.impl
send = compose2 reraise send.impl
closeSocket = compose reraise closeSocket.impl
clientSocket = compose2 reraise clientSocket.impl
receive = compose reraise receive.impl
terminate = compose reraise terminate.impl
newServer = compose2 reraise newServer.impl
socketAccept = compose reraise socketAccept.impl
socketPort = compose reraise socketPort.impl
newClient = compose2 reraise newClient.impl
MVar.take = compose reraise take.impl
MVar.put = compose2 reraise put.impl
MVar.swap = compose2 reraise MVar.swap.impl
```
The test shows that `hex (fromHex str) == str` as expected.
```unison
test> hex.tests.ex1 = checks let
s = "3984af9b"
[hex (fromHex s) == s]
```
Lets do some basic testing of our test harness to make sure its
working.
```unison
testAutoClean : '{io2.IO}[Result]
testAutoClean _ =
go: '{Stream Result, Exception, io2.IO, TempDirs} Text
go _ =
dir = newTempDir "autoclean"
check "our temporary directory should exist" (isDirectory dir)
dir
handle (evalTest go) with cases
{ Exception.raise (Failure _ t _) -> _ } -> [Fail t]
{ (results, dir) } ->
match io2.IO.isDirectory.impl dir with
Right b -> if b
then results :+ (Fail "our temporary directory should no longer exist")
else results :+ (Ok "our temporary directory should no longer exist")
Left (Failure _ t _) -> results :+ (Fail t)
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
testAutoClean : '{io2.IO} [Result]
```
```ucm
.> add
⍟ I've added these definitions:
testAutoClean : '{io2.IO} [Result]
.> io.test testAutoClean
New test results:
◉ testAutoClean our temporary directory should exist
◉ testAutoClean our temporary directory should no longer exist
✅ 2 test(s) passing
Tip: Use view testAutoClean to view the source of a test.
```

40
unison-src/new-runtime-transcripts/builtins.md
View File

@ -2,42 +2,6 @@
This transcript defines unit tests for builtin functions. There's a single `.> test` execution at the end that will fail the transcript with a nice report if any of the tests fail.
## Setup
```ucm:hide
.> builtins.merge
```
You can skip this section, which just defines setup functions we'll use for testing.
```unison:hide
check : Boolean -> [Result]
check b = if b then [Ok "Passed"] else [Fail "Failed"]
id x = x
checks : [Boolean] -> [Result]
checks bs =
if all id bs then [Ok "Passed"]
else [Fail "Failed"]
all : (a ->{m} Boolean) -> [a] ->{m} Boolean
all f = cases
[] -> true
h +: t -> f h && all f t
map : (a ->{m} b) -> [a] ->{m} [b]
map f xs =
go acc = cases
[] -> acc
h +: t -> go (acc :+ f h) t
go [] xs
```
```ucm:hide
.> add
```
## `Int` functions
```unison:hide
@ -186,8 +150,8 @@ test> Nat.tests.conversions =
```unison
> [Any "hi", Any (41 + 1)]
test> Any.test1 = check (Any "hi" == Any "hi")
test> Any.test2 = check (not (Any "hi" == Any 42))
test> Any.test1 = checks [(Any "hi" == Any "hi")]
test> Any.test2 = checks [(not (Any "hi" == Any 42))]
```
```ucm:hide

36
unison-src/new-runtime-transcripts/builtins.output.md
View File

@ -2,34 +2,6 @@
This transcript defines unit tests for builtin functions. There's a single `.> test` execution at the end that will fail the transcript with a nice report if any of the tests fail.
## Setup
You can skip this section, which just defines setup functions we'll use for testing.
```unison
check : Boolean -> [Result]
check b = if b then [Ok "Passed"] else [Fail "Failed"]
id x = x
checks : [Boolean] -> [Result]
checks bs =
if all id bs then [Ok "Passed"]
else [Fail "Failed"]
all : (a ->{m} Boolean) -> [a] ->{m} Boolean
all f = cases
[] -> true
h +: t -> f h && all f t
map : (a ->{m} b) -> [a] ->{m} [b]
map f xs =
go acc = cases
[] -> acc
h +: t -> go (acc :+ f h) t
go [] xs
```
## `Int` functions
```unison
@ -170,8 +142,8 @@ test> Nat.tests.conversions =
```unison
> [Any "hi", Any (41 + 1)]
test> Any.test1 = check (Any "hi" == Any "hi")
test> Any.test2 = check (not (Any "hi" == Any 42))
test> Any.test1 = checks [(Any "hi" == Any "hi")]
test> Any.test2 = checks [(not (Any "hi" == Any 42))]
```
```ucm
@ -192,11 +164,11 @@ test> Any.test2 = check (not (Any "hi" == Any 42))
⧩
[Any "hi", Any 42]
3 | test> Any.test1 = check (Any "hi" == Any "hi")
3 | test> Any.test1 = checks [(Any "hi" == Any "hi")]
✅ Passed Passed
4 | test> Any.test2 = check (not (Any "hi" == Any 42))
4 | test> Any.test2 = checks [(not (Any "hi" == Any 42))]
✅ Passed Passed

24
unison-src/new-runtime-transcripts/codeops.md
View File

@ -10,30 +10,27 @@ Define a function, serialize it, then deserialize it back to an actual
function. Also ask for its dependencies for display later.
```unison
ability Err where
throw : Text -> a
save : a -> Bytes
save x = Value.serialize (Value.value x)
load : Bytes ->{io2.IO, Err} a
load : Bytes ->{io2.IO, Throw Text} a
load b = match Value.deserialize b with
Left _ -> throw "could not deserialize value"
Right v -> match Value.load v with
Left _ -> throw "could not load value"
Right x -> x
roundtrip : a ->{io2.IO, Err} a
roundtrip : a ->{io2.IO, Throw Text} a
roundtrip x = load (save x)
handleTest : Text -> Request {Err} a -> Result
handleTest : Text -> Request {Throw Text} a -> Result
handleTest t = let
pfx = "(" ++ t ++ ") "
cases
{ _ } -> Ok (pfx ++ "passed")
{ throw s -> _ } -> Fail (pfx ++ s)
{ Throw.throw s -> _ } -> Fail (pfx ++ s)
identical : Text -> a -> a ->{Err} ()
identical : Text -> a -> a ->{Throw Text} ()
identical err x y =
if x == y
then ()
@ -47,11 +44,6 @@ showThree = cases
one n -> "one " ++ toText n
two n -> "two " ++ toText n
map : (a -> b) -> [a] -> [b]
map f = cases
[] -> []
x +: xs -> f x +: map f xs
concatMap : (a -> [b]) -> [a] -> [b]
concatMap f = cases
[] -> []
@ -69,7 +61,7 @@ extensionals
: (a -> b -> Text)
-> (a -> b -> c)
-> (a -> b -> c)
-> [(a,b)] ->{Err} ()
-> [(a,b)] ->{Throw Text} ()
extensionals sh f g = cases
[] -> ()
(x,y) +: xs ->
@ -79,7 +71,7 @@ extensionals sh f g = cases
fib10 : [Nat]
fib10 = [1,2,3,5,8,13,21,34,55,89]
extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) ->{IO} Result
extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) ->{io2.IO} Result
extensionality t f = let
sh t n = "(" ++ showThree t ++ ", " ++ toText n ++ ")"
handle
@ -87,7 +79,7 @@ extensionality t f = let
extensionals sh f g (prod threes fib10)
with handleTest t
identicality : Text -> a ->{IO} Result
identicality : Text -> a ->{io2.IO} Result
identicality t x
= handle identical "" x (roundtrip x) with handleTest t
```

92
unison-src/new-runtime-transcripts/codeops.output.md
View File

@ -5,30 +5,27 @@ Define a function, serialize it, then deserialize it back to an actual
function. Also ask for its dependencies for display later.
```unison
ability Err where
throw : Text -> a
save : a -> Bytes
save x = Value.serialize (Value.value x)
load : Bytes ->{io2.IO, Err} a
load : Bytes ->{io2.IO, Throw Text} a
load b = match Value.deserialize b with
Left _ -> throw "could not deserialize value"
Right v -> match Value.load v with
Left _ -> throw "could not load value"
Right x -> x
roundtrip : a ->{io2.IO, Err} a
roundtrip : a ->{io2.IO, Throw Text} a
roundtrip x = load (save x)
handleTest : Text -> Request {Err} a -> Result
handleTest : Text -> Request {Throw Text} a -> Result
handleTest t = let
pfx = "(" ++ t ++ ") "
cases
{ _ } -> Ok (pfx ++ "passed")
{ throw s -> _ } -> Fail (pfx ++ s)
{ Throw.throw s -> _ } -> Fail (pfx ++ s)
identical : Text -> a -> a ->{Err} ()
identical : Text -> a -> a ->{Throw Text} ()
identical err x y =
if x == y
then ()
@ -42,11 +39,6 @@ showThree = cases
one n -> "one " ++ toText n
two n -> "two " ++ toText n
map : (a -> b) -> [a] -> [b]
map f = cases
[] -> []
x +: xs -> f x +: map f xs
concatMap : (a -> [b]) -> [a] -> [b]
concatMap f = cases
[] -> []
@ -64,7 +56,7 @@ extensionals
: (a -> b -> Text)
-> (a -> b -> c)
-> (a -> b -> c)
-> [(a,b)] ->{Err} ()
-> [(a,b)] ->{Throw Text} ()
extensionals sh f g = cases
[] -> ()
(x,y) +: xs ->
@ -74,7 +66,7 @@ extensionals sh f g = cases
fib10 : [Nat]
fib10 = [1,2,3,5,8,13,21,34,55,89]
extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) ->{IO} Result
extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) ->{io2.IO} Result
extensionality t f = let
sh t n = "(" ++ showThree t ++ ", " ++ toText n ++ ")"
handle
@ -82,7 +74,7 @@ extensionality t f = let
extensionals sh f g (prod threes fib10)
with handleTest t
identicality : Text -> a ->{IO} Result
identicality : Text -> a ->{io2.IO} Result
identicality t x
= handle identical "" x (roundtrip x) with handleTest t
```
@ -95,27 +87,29 @@ identicality t x
⍟ These new definitions are ok to `add`:
ability Err
type Three a b c
concatMap : (a ->{g} [b]) ->{g} [a] ->{g} [b]
extensionality : Text
-> (Three Nat Nat Nat
->{Err} Nat
->{Err} b)
->{IO} Result
extensionals : (a ->{Err} b ->{Err} Text)
->{Err} (a ->{Err} b ->{Err} c)
->{Err} (a ->{Err} b ->{Err} c)
->{Err} [(a, b)]
->{Err} ()
->{Throw Text} Nat
->{Throw Text} b)
->{io2.IO} Result
extensionals : (a ->{Throw Text} b ->{Throw Text} Text)
->{Throw Text} (a
->{Throw Text} b
->{Throw Text} c)
->{Throw Text} (a
->{Throw Text} b
->{Throw Text} c)
->{Throw Text} [(a, b)]
->{Throw Text} ()
fib10 : [Nat]
handleTest : Text -> Request {Err} a -> Result
identical : Text -> a -> a ->{Err} ()
identicality : Text -> a ->{IO} Result
load : Bytes ->{IO, Err} a
map : (a ->{g} b) ->{g} [a] ->{g} [b]
handleTest : Text -> Request {Throw Text} a -> Result
identical : Text -> a -> a ->{Throw Text} ()
identicality : Text -> a ->{io2.IO} Result
load : Bytes ->{io2.IO, Throw Text} a
prod : [a] ->{g} [b] ->{g} [(a, b)]
roundtrip : a ->{IO, Err} a
roundtrip : a ->{io2.IO, Throw Text} a
save : a -> Bytes
showThree : Three Nat Nat Nat -> Text
threes : [Three Nat Nat Nat]
@ -126,27 +120,29 @@ identicality t x
⍟ I've added these definitions:
ability Err
type Three a b c
concatMap : (a ->{g} [b]) ->{g} [a] ->{g} [b]
extensionality : Text
-> (Three Nat Nat Nat
->{Err} Nat
->{Err} b)
->{IO} Result
extensionals : (a ->{Err} b ->{Err} Text)
->{Err} (a ->{Err} b ->{Err} c)
->{Err} (a ->{Err} b ->{Err} c)
->{Err} [(a, b)]
->{Err} ()
->{Throw Text} Nat
->{Throw Text} b)
->{io2.IO} Result
extensionals : (a ->{Throw Text} b ->{Throw Text} Text)
->{Throw Text} (a
->{Throw Text} b
->{Throw Text} c)
->{Throw Text} (a
->{Throw Text} b
->{Throw Text} c)
->{Throw Text} [(a, b)]
->{Throw Text} ()
fib10 : [Nat]
handleTest : Text -> Request {Err} a -> Result
identical : Text -> a -> a ->{Err} ()
identicality : Text -> a ->{IO} Result
load : Bytes ->{IO, Err} a
map : (a ->{g} b) ->{g} [a] ->{g} [b]
handleTest : Text -> Request {Throw Text} a -> Result
identical : Text -> a -> a ->{Throw Text} ()
identicality : Text -> a ->{io2.IO} Result
load : Bytes ->{io2.IO, Throw Text} a
prod : [a] ->{g} [b] ->{g} [(a, b)]
roundtrip : a ->{IO, Err} a
roundtrip : a ->{io2.IO, Throw Text} a
save : a -> Bytes
showThree : Three Nat Nat Nat -> Text
threes : [Three Nat Nat Nat]
@ -218,7 +214,7 @@ tests =
fVal : Value
h : Three Nat Nat Nat -> Nat -> Nat
rotate : Three Nat Nat Nat -> Three Nat Nat Nat
tests : '{IO} [Result]
tests : '{io2.IO} [Result]
zapper : Three Nat Nat Nat ->{g} Request {Zap} r ->{g} r
```
@ -238,7 +234,7 @@ to actual show that the serialization works.
fVal : Value
h : Three Nat Nat Nat -> Nat -> Nat
rotate : Three Nat Nat Nat -> Three Nat Nat Nat
tests : '{IO} [Result]
tests : '{io2.IO} [Result]
zapper : Three Nat Nat Nat ->{g} Request {Zap} r ->{g} r
.> display fDeps

3
unison-src/new-runtime-transcripts/fix1709.output.md
View File

@ -12,9 +12,10 @@ id2 x =
do an `add` or `update`, here's how your codebase would
change:
⊡ Previously added definitions will be ignored: id
⍟ These new definitions are ok to `add`:
id : x -> x
id2 : x -> x
```

59
unison-src/new-runtime-transcripts/hashing.md
View File

@ -7,53 +7,11 @@
Unison has cryptographic builtins for hashing and computing [HMACs](https://en.wikipedia.org/wiki/HMAC) (hash-based message authentication codes). This transcript shows their usage and has some test cases.
## Setup
You can skip this section, which is just needed to make the transcript self-contained. In order to print out and test these hashes we will be using some builtins for base16 (aka hexidecimal) encoding and decoding.
```ucm
.builtin> ls Bytes
```
Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`.
```unison:hide
a |> f = f a
hex : Bytes -> Text
hex b =
match Bytes.toBase16 b |> fromUtf8
with Left e -> bug e
Right t -> t
ascii : Text -> Bytes
ascii = toUtf8
fromHex : Text -> Bytes
fromHex txt =
match toUtf8 txt |> Bytes.fromBase16
with Left e -> bug e
Right bs -> bs
check : Boolean -> [Result]
check b = if b then [Result.Ok "Passed."]
else [Result.Fail "Failed."]
test> hex.tests.ex1 = check let
s = "3984af9b"
hex (fromHex s) == s
```
```ucm:hide
.scratch> add
```
The test shows that `hex (fromHex str) == str` as expected.
```ucm
.scratch> test
```
## API overview
Here's a few usage examples:
@ -71,7 +29,7 @@ mysecret : Bytes
mysecret = fromHex "237be2"
ex3 = fromHex "50d3ab"
|> crypto.hmacBytes Sha2_256 mysecret
|> (crypto.hmacBytes Sha2_256 mysecret)
|> hex
f x = x
@ -104,9 +62,7 @@ Note that the universal versions of `hash` and `hmac` are currently unimplemente
Here are some test vectors (taken from [here](https://www.di-mgt.com.au/sha_testvectors.html) and [here](https://en.wikipedia.org/wiki/BLAKE_(hash_function))) for the various hashing algorithms:
```unison:hide
ex alg input expected = check let
hashBytes alg (ascii input) ==
fromHex expected
ex alg input expected = checks [hashBytes alg (ascii input) == fromHex expected]
test> sha3_512.tests.ex1 =
ex Sha3_512
@ -222,16 +178,13 @@ test> blake2b_512.tests.ex3 =
These test vectors are taken from [RFC 4231](https://tools.ietf.org/html/rfc4231#section-4.3).
```unison
ex' alg secret msg expected = check let
hmacBytes alg (fromHex secret) (ascii msg) ==
fromHex expected
ex' alg secret msg expected = checks [hmacBytes alg (fromHex secret) (ascii msg) == fromHex expected]
test> hmac_sha2_256.tests.ex1 =
ex' Sha2_256
"0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
"Hi There"
ex' Sha2_256
"0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
"Hi There"
"b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7"
test> hmac_sha2_512.tests.ex1 =
ex' Sha2_512
"0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"

Some files were not shown because too many files have changed in this diff Show More