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

Merge branch 'trunk' into cp/namespace-dependencies

Browse Source
This commit is contained in:
Chris Penner 2021-11-16 10:26:19 -06:00
commit 15414f38ed
27 changed files with 252 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -60,8 +60,8 @@ jobs:
# recent branch cache.
# Then it will save a new cache at this commit sha, which should be used by
# the next build on this branch.
key: stack-work-2_${{matrix.os}}-${{github.sha}}
restore-keys: stack-work-2_${{matrix.os}}
key: stack-work-3_${{matrix.os}}-${{github.sha}}
restore-keys: stack-work-3_${{matrix.os}}
# Install stack by downloading the binary from GitHub. The installation process is different for Linux and macOS,
# so this is split into two steps, only one of which will run on any particular build.

4
codebase2/util/bench/Main.hs
View File

@ -12,7 +12,7 @@ import qualified U.Util.Base32Hex as U.Base32Hex
main :: IO ()
main = do
let textual = U.Base32Hex.UnsafeBase32Hex "kccnret7m1895ta8ncs3ct5pqmguqntvjlcsr270ug8mbqvkh07v983i12obpgsii0gbga2esk1423t6evr03f62hkkfllrrj7iil30"
let textual = U.Base32Hex.UnsafeFromText "kccnret7m1895ta8ncs3ct5pqmguqntvjlcsr270ug8mbqvkh07v983i12obpgsii0gbga2esk1423t6evr03f62hkkfllrrj7iil30"
let binary = "\163\EM}\187\167\176P\146\245H\187\&86t\185\213\161\237_\191\157Y\205\136\224\244\DC1e\235\244\136\SI\244\160r\b\176\188\195\146\144 \184(N\229\STXA\SI\166w\246\SOH\188\194\141(\250\215{\153\229*\140"
defaultMain
@ -29,7 +29,7 @@ sandi_fromByteString bs =
-- The old implementation of `toByteString` which used `sandi`
sandi_toByteString :: U.Base32Hex.Base32Hex -> ByteString
sandi_toByteString (U.Base32Hex.UnsafeBase32Hex txt) =
sandi_toByteString (U.Base32Hex.UnsafeFromText txt) =
case Sandi.decode (Text.encodeUtf8 (Text.toUpper txt <> paddingChars)) of
Left (_, _rem) -> error ("not base32: " <> Text.unpack txt)
Right h -> h

1
codebase2/util/package.yaml
View File

@ -19,6 +19,7 @@ dependencies:
- bytestring
- containers
- cryptonite
- extra
- lens
- memory
- safe

27
codebase2/util/src/U/Util/Base32Hex.hs
View File

@ -1,28 +1,47 @@
{-# LANGUAGE ViewPatterns #-}
module U.Util.Base32Hex
( Base32Hex (..),
( Base32Hex (UnsafeFromText),
fromByteString,
toByteString,
fromText,
toText,
validChars,
)
where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base32.Hex as Base32.Hex
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
newtype Base32Hex = UnsafeBase32Hex {toText :: Text}
newtype Base32Hex = UnsafeFromText Text
deriving (Eq, Ord, Show)
toText :: Base32Hex -> Text
toText (UnsafeFromText s) = s
-- | Return the lowercase unpadded base32Hex encoding of this 'ByteString'.
-- Multibase prefix would be 'v', see https://github.com/multiformats/multibase
fromByteString :: ByteString -> Base32Hex
fromByteString =
UnsafeBase32Hex . Text.toLower . Base32.Hex.encodeBase32Unpadded
UnsafeFromText . Text.toLower . Base32.Hex.encodeBase32Unpadded
-- | Produce a 'Hash' from a base32hex-encoded version of its binary representation
toByteString :: Base32Hex -> ByteString
toByteString (UnsafeBase32Hex s) =
toByteString (UnsafeFromText s) =
case Base32.Hex.decodeBase32Unpadded (Text.encodeUtf8 s) of
Left _ -> error ("not base32: " <> Text.unpack s)
Right h -> h
fromText :: Text -> Maybe Base32Hex
fromText s =
if Base32.Hex.isBase32Hex . Text.encodeUtf8 . Text.toUpper $ s
then Just (UnsafeFromText s)
else Nothing
validChars :: Set Char
validChars = Set.fromList $ ['0' .. '9'] ++ ['a' .. 'v']

33
codebase2/util/src/U/Util/Hash.hs
View File

@ -1,33 +1,40 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module U.Util.Hash where
-- (Hash, toBytes, base32Hex, base32Hexs, fromBase32Hex, fromBytes, unsafeFromBase32Hex, showBase32Hex, validBase32HexChars) where
-- import Unison.Prelude
module U.Util.Hash
( Hash (Hash, toShort),
fromBase32Hex,
fromByteString,
toBase32Hex,
toByteString,
)
where
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString, fromShort)
import qualified Data.ByteString.Short as B.Short
import Data.Text (Text)
import GHC.Generics (Generic)
import Data.ByteString.Short (fromShort, ShortByteString)
import qualified U.Util.Base32Hex as Base32Hex
import U.Util.Base32Hex (Base32Hex)
import qualified U.Util.Base32Hex as Base32Hex
-- | Hash which uniquely identifies a Unison type or term
newtype Hash = Hash {toShort :: ShortByteString} deriving (Eq, Ord, Generic)
toBase32Hex :: Hash -> Base32Hex
toBase32Hex = Base32Hex.fromByteString . toBytes
toBase32Hex = Base32Hex.fromByteString . toByteString
toBase32HexText :: Hash -> Text
toBase32HexText = Base32Hex.toText . toBase32Hex
fromBase32Hex :: Base32Hex -> Hash
fromBase32Hex = Hash . B.Short.toShort . Base32Hex.toByteString
toBytes :: Hash -> ByteString
toBytes = fromShort . toShort
toByteString :: Hash -> ByteString
toByteString = fromShort . toShort
fromBytes :: ByteString -> Hash
fromBytes = Hash . B.Short.toShort
fromByteString :: ByteString -> Hash
fromByteString = Hash . B.Short.toShort
instance Show Hash where
show h = "fromBase32Hex " ++ (show . Base32Hex.toText . toBase32Hex) h
show h = (show . toBase32HexText) h

2
codebase2/util/unison-util.cabal
View File

@ -54,6 +54,7 @@ library
, bytestring
, containers
, cryptonite
, extra
, lens
, memory
, safe
@ -93,6 +94,7 @@ benchmark bench
, containers
, criterion
, cryptonite
, extra
, lens
, memory
, safe

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

@ -144,11 +144,10 @@ getTypeOfConstructor codebase (Reference.DerivedId r) cid = do
getTypeOfConstructor _ r cid =
error $ "Don't know how to getTypeOfConstructor " ++ show r ++ " " ++ show cid
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference -> m (Maybe (Term v a))
lookupWatchCache codebase (Reference.DerivedId h) = do
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference.Id -> m (Maybe (Term v a))
lookupWatchCache codebase h = do
m1 <- getWatch codebase WK.RegularWatch h
maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
lookupWatchCache _ Reference.Builtin{} = pure Nothing
typeLookupForDependencies
:: (Monad m, Var v, BuiltinAnnotation a)

21
parser-typechecker/src/Unison/Codebase/Runtime.hs
View File

@ -47,14 +47,14 @@ data Runtime v = Runtime
type IsCacheHit = Bool
noCache :: Reference -> IO (Maybe (Term v))
noCache :: Reference.Id -> IO (Maybe (Term v))
noCache _ = pure Nothing
type WatchResults v a = (Either Error
-- Bindings:
( [(v, Term v)]
-- Map watchName (loc, hash, expression, value, isHit)
, Map v (a, WatchKind, Reference, Term v, Term v, IsCacheHit)
, Map v (a, WatchKind, Reference.Id, Term v, Term v, IsCacheHit)
))
-- Evaluates the watch expressions in the file, returning a `Map` of their
@ -70,14 +70,14 @@ evaluateWatches
. Var v
=> CL.CodeLookup v IO a
-> PPE.PrettyPrintEnv
-> (Reference -> IO (Maybe (Term v)))
-> (Reference.Id -> IO (Maybe (Term v)))
-> Runtime v
-> TypecheckedUnisonFile v a
-> IO (WatchResults v a)
evaluateWatches code ppe evaluationCache rt tuf = do
-- 1. compute hashes for everything in the file
let m :: Map v (Reference, Term.Term v a)
m = fmap (\(id, _wk, tm, _tp) -> (Reference.DerivedId id, tm)) (UF.hashTermsId tuf)
let m :: Map v (Reference.Id, Term.Term v a)
m = fmap (\(id, _wk, tm, _tp) -> (id, tm)) (UF.hashTermsId tuf)
watches :: Set v = Map.keysSet watchKinds
watchKinds :: Map v WatchKind
watchKinds =
@ -91,7 +91,7 @@ evaluateWatches code ppe evaluationCache rt tuf = do
Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
Just t' -> pure (v, (r, ABT.annotation t, t', True))
-- 3. create a big ol' let rec whose body is a big tuple of all watches
let rv :: Map Reference v
let rv :: Map Reference.Id v
rv = Map.fromList [ (r, v) | (v, (r, _)) <- Map.toList m ]
bindings :: [(v, Term v)]
bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ]
@ -117,10 +117,10 @@ evaluateWatches code ppe evaluationCache rt tuf = do
pure $ Right (bindings, watchMap)
Left e -> pure (Left e)
where
-- unref :: Map Reference v -> Term.Term v a -> Term.Term v a
-- unref :: Map Reference.Id v -> Term.Term v a -> Term.Term v a
unref rv t = ABT.visitPure go t
where
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
go t@(Term.Ref' (Reference.DerivedId r)) = case Map.lookup r rv of
Nothing -> Nothing
Just v -> Just (Term.var (ABT.annotation t) v)
go _ = Nothing
@ -128,14 +128,13 @@ evaluateWatches code ppe evaluationCache rt tuf = do
evaluateTerm'
:: (Var v, Monoid a)
=> CL.CodeLookup v IO a
-> (Reference -> IO (Maybe (Term v)))
-> (Reference.Id -> IO (Maybe (Term v)))
-> PPE.PrettyPrintEnv
-> Runtime v
-> Term.Term v a
-> IO (Either Error (Term v))
evaluateTerm' codeLookup cache ppe rt tm = do
let ref = Reference.DerivedId (Hashing.hashClosedTerm tm)
result <- cache ref
result <- cache (Hashing.hashClosedTerm tm)
case result of
Just r -> pure (Right r)
Nothing -> do

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

@ -28,7 +28,6 @@ import Data.Bytes.VarInt ( VarInt(..) )
import Data.Bifunctor (bimap)
import qualified Data.Char as Char
import Data.List.NonEmpty (NonEmpty (..))
-- import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Typeable (Proxy (..))
@ -45,6 +44,7 @@ import Unison.Term (MatchCase (..))
import Unison.Var (Var)
import qualified Unison.Var as Var
import qualified Unison.UnisonFile.Error as UF
import qualified U.Util.Base32Hex as Base32Hex
import Unison.Util.Bytes (Bytes)
import Unison.Name as Name
import Unison.NamesWithHistory (NamesWithHistory)
@ -99,7 +99,7 @@ uniqueName :: Var v => Int -> P v Text
uniqueName lenInBase32Hex = do
UniqueName mkName <- asks uniqueNames
pos <- L.start <$> P.lookAhead anyToken
let none = Hash.base32Hex . Hash.fromBytes . encodeUtf8 . Text.pack $ show pos
let none = Base32Hex.toText . Base32Hex.fromByteString . encodeUtf8 . Text.pack $ show pos
pure . fromMaybe none $ mkName pos lenInBase32Hex
data Error v

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

@ -8,7 +8,6 @@ import Data.Foldable (traverse_)
import qualified Data.Vector.Primitive as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Short as SBS
import Data.Bits (Bits)
import Data.Bytes.Put
import Data.Bytes.Get hiding (getBytes)
@ -28,7 +27,7 @@ import Unison.Referent (Referent, pattern Ref, pattern Con)
import qualified Unison.Util.Bytes as Bytes
import Unison.Util.EnumContainers as EC
import Unison.Hash (Hash)
import qualified Unison.Hash as Hash
import qualified U.Util.Hash as Hash
import qualified Unison.ConstructorType as CT
import Unison.Runtime.Exception
import Unison.Runtime.MCode
@ -148,7 +147,7 @@ putBlock b = putLength (BA.length b) *> putByteString (Bytes.chunkToByteString b
putHash :: MonadPut m => Hash -> m ()
putHash h = do
let bs = SBS.fromShort $ Hash.toBytes h
let bs = Hash.toByteString h
putLength (B.length bs)
putByteString bs
@ -156,7 +155,7 @@ getHash :: MonadGet m => m Hash
getHash = do
len <- getLength
bs <- B.copy <$> Ser.getBytes len
pure $ Hash.fromBytes bs
pure $ Hash.fromByteString bs
putReferent :: MonadPut m => Referent -> m ()
putReferent = \case

17
parser-typechecker/src/Unison/Server/Doc/AsHtml.hs
View File

@ -97,8 +97,8 @@ foldedToHtml attrs isFolded =
then open_ "open" : attrs
else attrs
in details_ attrsWithOpen $ do
summary_ [class_ "folded-content"] $ sequence_ summary
div_ [class_ "folded-content"] $ sequence_ details
summary_ [class_ "folded-content folded-summary"] $ sequence_ summary
div_ [class_ "folded-content folded-details"] $ sequence_ details
foldedToHtmlSource :: Bool -> EmbeddedSource -> Html ()
foldedToHtmlSource isFolded source =
@ -196,7 +196,7 @@ toHtml docNamesByRef document =
Code code ->
span_ [class_ "rich source inline-code"] $ inlineCode [] (currentSectionLevelToHtml code)
CodeBlock lang code ->
div_ [class_ "rich source code", class_ $ textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
div_ [class_ $ "rich source code " <> textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
Bold d ->
strong_ [] $ currentSectionLevelToHtml d
Italic d ->
@ -249,7 +249,12 @@ toHtml docNamesByRef document =
IsFolded
isFolded
[currentSectionLevelToHtml summary]
[currentSectionLevelToHtml details]
-- We include the summary in the details slot to make it
-- symmetric with code folding, which currently always
-- includes the type signature in the details portion
[ div_ [] $ currentSectionLevelToHtml summary,
currentSectionLevelToHtml details
]
Paragraph docs ->
case docs of
[d] ->
@ -314,14 +319,14 @@ toHtml docNamesByRef document =
Link syntax ->
inlineCode ["rich", "source"] $ Syntax.toHtml syntax
Signature signatures ->
div_
codeBlock
[class_ "rich source signatures"]
( mapM_
(div_ [class_ "signature"] . Syntax.toHtml)
signatures
)
SignatureInline sig ->
span_ [class_ "rich source signature-inline"] $ Syntax.toHtml sig
inlineCode ["rich", "source", "signature-inline"] $ Syntax.toHtml sig
Eval source result ->
div_ [class_ "source rich eval"] $
codeBlock [] $

5
parser-typechecker/tests/Unison/Test/DataDeclaration.hs
View File

@ -4,11 +4,12 @@ module Unison.Test.DataDeclaration where
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.Text.Encoding (encodeUtf8)
import EasyTest
import Text.RawString.QQ
import qualified U.Util.Hash as Hash
import Unison.DataDeclaration (DataDeclaration (..), Decl)
import qualified Unison.DataDeclaration as DD
import qualified Unison.Hash as Hash
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Parser.Ann (Ann)
import Unison.Parsers (unsafeParseFile)
@ -87,7 +88,7 @@ unhashComponentTest = tests
app = Type.app ()
forall = Type.forall ()
(-->) = Type.arrow ()
h = Hash.unsafeFromBase32Hex "abcd"
h = Hash.fromByteString (encodeUtf8 "abcd")
ref = R.Derived h 0 1
a = Var.refNamed ref
b = Var.named "b"

5
parser-typechecker/tests/Unison/Test/Term.hs
View File

@ -5,7 +5,8 @@ module Unison.Test.Term where
import EasyTest
import qualified Data.Map as Map
import Data.Map ( (!) )
import qualified Unison.Hash as Hash
import Data.Text.Encoding (encodeUtf8)
import qualified U.Util.Hash as Hash
import qualified Unison.Reference as R
import Unison.Symbol ( Symbol )
import qualified Unison.Term as Term
@ -40,7 +41,7 @@ test = scope "term" $ tests
expect $ tm' == expected
ok
, scope "Term.unhashComponent" $
let h = Hash.unsafeFromBase32Hex "abcd"
let h = Hash.fromByteString (encodeUtf8 "abcd")
ref = R.Derived h 0 1
v1 = Var.refNamed @Symbol ref
-- input component: `ref = \v1 -> ref`

2
unison-cli/src/Unison/Codebase/Editor/Command.hs
View File

@ -265,7 +265,7 @@ type UseCache = Bool
type EvalResult v =
( [(v, Term v ())]
, Map v (Ann, WK.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit)
, Map v (Ann, WK.WatchKind, Reference.Id, Term v (), Term v (), Runtime.IsCacheHit)
)
lookupEvalResult :: Ord v => v -> EvalResult v -> Maybe (Term v ())

17
unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -199,11 +199,10 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
ClearWatchCache -> lift $ Codebase.clearWatches codebase
FuzzySelect opts display choices -> liftIO $ Fuzzy.fuzzySelect opts display choices
watchCache (Reference.DerivedId h) = do
m1 <- Codebase.getWatch codebase WK.RegularWatch h
m2 <- maybe (Codebase.getWatch codebase WK.TestWatch h) (pure . Just) m1
pure $ Term.amap (const ()) <$> m2
watchCache Reference.Builtin{} = pure Nothing
watchCache :: Reference.Id -> IO (Maybe (Term v ()))
watchCache h = do
maybeTerm <- Codebase.lookupWatchCache codebase h
pure (Term.amap (const ()) <$> maybeTerm)
eval1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> _
eval1 ppe useCache tm = do
@ -225,11 +224,9 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
Right rs@(_,map) -> do
forM_ (Map.elems map) $ \(_loc, kind, hash, _src, value, isHit) ->
if isHit then pure ()
else case hash of
Reference.DerivedId h -> do
let value' = Term.amap (const Ann.External) value
Codebase.putWatch codebase kind h value'
Reference.Builtin{} -> pure ()
else do
let value' = Term.amap (const Ann.External) value
Codebase.putWatch codebase kind hash value'
pure $ Right rs
-- doTodo :: Monad m => Codebase m v a -> Branch0 -> m (TodoOutput v a)

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

@ -146,6 +146,13 @@ defaultPatchNameSegment = "patch"
prettyPrintEnvDecl :: NamesWithHistory -> Action' m v PPE.PrettyPrintEnvDecl
prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns)
-- | Get a pretty print env decl for the current names at the current path.
currentPrettyPrintEnvDecl :: Action' m v PPE.PrettyPrintEnvDecl
currentPrettyPrintEnvDecl = do
root' <- use root
currentPath' <- Path.unabsolute <$> use currentPath
prettyPrintEnvDecl (Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root')
loop :: forall m v. (Monad m, Var v) => Action m (Either Event Input) v ()
loop = do
uf <- use LoopState.latestTypecheckedFile
@ -1648,23 +1655,7 @@ loop = do
let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path
lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b printDiffPath destAbs
PushRemoteBranchI mayRepo path pushBehavior syncMode -> handlePushRemoteBranch mayRepo path pushBehavior syncMode
ListDependentsI hq ->
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
if null lds
then respond $ LabeledReferenceNotFound hq
else for_ lds $ \ld -> do
dependents <-
let tp r = eval $ GetDependents r
tm (Referent.Ref r) = eval $ GetDependents r
tm (Referent.Con r _i _ct) = eval $ GetDependents r
in LD.fold tp tm ld
(missing, names0) <- eval . Eval $ Branch.findHistoricalRefs' dependents root'
let types = R.toList $ Names.types names0
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
let names = types <> terms
LoopState.numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
respond $ ListDependents hqLength ld names missing
ListDependentsI hq -> handleDependents hq
ListDependenciesI hq ->
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
@ -1793,6 +1784,42 @@ loop = do
Right input -> LoopState.lastInput .= Just input
_ -> pure ()
handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v ()
handleDependents hq = do
hqLength <- eval CodebaseHashLength
-- todo: add flag to handle transitive efficiently
resolveHQToLabeledDependencies hq >>= \lds ->
if null lds
then respond $ LabeledReferenceNotFound hq
else for_ lds \ld -> do
-- The full set of dependent references, any number of which may not have names in the current namespace.
dependents <-
let tp r = eval $ GetDependents r
tm (Referent.Ref r) = eval $ GetDependents r
tm (Referent.Con r _i _ct) = eval $ GetDependents r
in LD.fold tp tm ld
-- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
-- unambiguous name.
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl
let results :: [(Reference, Maybe Name)]
results =
-- Currently we only retain dependents that are named in the current namespace (hence `mapMaybe`). In the future, we could
-- take a flag to control whether we want to show all dependents
mapMaybe f (Set.toList dependents)
where
f :: Reference -> Maybe (Reference, Maybe Name)
f reference =
asum
[ g <$> PPE.terms ppe (Referent.Ref reference),
g <$> PPE.types ppe reference
]
where
g :: HQ'.HashQualified Name -> (Reference, Maybe Name)
g hqName =
(reference, Just (HQ'.toName hqName))
numberedArgs .= map (Text.unpack . Reference.toText . fst) results
respond (ListDependents hqLength ld results)
handlePushRemoteBranch ::
forall m v.
Applicative m =>

3
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -210,7 +210,8 @@ data Output v
| NotImplemented
| NoBranchWithHash ShortBranchHash
| ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference)
| ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference)
| -- | List dependents of a type or term.
ListDependents Int LabeledDependency [(Reference, Maybe Name)]
| -- | List all direct dependencies which don't have any names in the current branch
ListNamespaceDependencies
PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace.

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

@ -1610,7 +1610,7 @@ dependents =
"dependents"
[]
[]
"List the dependents of the specified definition."
"List the named dependents of the specified definition."
( \case
[thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing
_ -> Left (I.help dependents)

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

@ -931,7 +931,7 @@ notifyUser dir o = case o of
CouldntLoadRootBranch repo hash ->
P.wrap $
"I couldn't load the designated root hash"
<> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")")
<> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unRawHash hash) <> ")")
<> "from the repository at"
<> prettyReadRepo repo
CouldntLoadSyncedBranch ns h ->
@ -1312,24 +1312,28 @@ notifyUser dir o = case o of
"",
"Paste that output into http://bit-booster.com/graph.html"
]
ListDependents hqLength ld names missing ->
ListDependents hqLength ld results ->
pure $
if names == mempty && missing == mempty
then c (prettyLabeledDependency hqLength ld) <> " doesn't have any dependents."
if null results
then prettyLd <> " doesn't have any named dependents."
else
"Dependents of " <> c (prettyLabeledDependency hqLength ld) <> ":\n\n"
<> (P.indentN 2 (P.numberedColumn2Header num pairs))
P.lines
[ "Dependents of " <> prettyLd <> ":",
"",
P.indentN 2 (P.numberedColumn2Header num pairs)
]
where
prettyLd = P.syntaxToColor (prettyLabeledDependency hqLength ld)
num n = P.hiBlack $ P.shown n <> "."
header = (P.hiBlack "Reference", P.hiBlack "Name")
pairs =
header :
( fmap (first c . second c) $
[(p $ Reference.toShortHash r, prettyName n) | (n, r) <- names]
++ [(p $ Reference.toShortHash r, "(no name available)") | r <- toList missing]
pairs = header : map pair results
pair :: (Reference, Maybe Name) -> (Pretty, Pretty)
pair (reference, maybeName) =
( prettyShortHash (SH.take hqLength (Reference.toShortHash reference)),
case maybeName of
Nothing -> ""
Just name -> prettyName name
)
p = prettyShortHash . SH.take hqLength
c = P.syntaxToColor
-- this definition is identical to the previous one, apart from the word
-- "Dependencies", but undecided about whether or how to refactor
ListDependencies hqLength ld names missing ->

2
unison-core/package.yaml
View File

@ -20,10 +20,10 @@ library:
- mtl
- rfc5051
- safe
- sandi
- text
- transformers
- unison-prelude
- unison-util
- unison-util-relation
- util
- vector

124
unison-core/src/Unison/Hash.hs
View File

@ -2,123 +2,27 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.Hash
( Hash(Hash)
, toBytes
, base32Hex
, base32Hexs
, fromBase32Hex
, fromBytes
, fromByteString
, toByteString
, unsafeFromBase32Hex
, showBase32Hex
, validBase32HexChars
) where
( Hash (Hash),
base32Hex,
fromBase32Hex,
Hash.toByteString,
validBase32HexChars,
)
where
import qualified U.Util.Base32Hex as Base32Hex
import U.Util.Hash (Hash (Hash))
import qualified U.Util.Hash as Hash
import Unison.Prelude
import Data.ByteString.Builder (doubleBE, word64BE, int64BE, toLazyByteString)
import qualified Data.ByteArray as BA
import qualified Crypto.Hash as CH
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as SBS
import qualified Unison.Hashable as H
import qualified Codec.Binary.Base32Hex as Base32Hex
import qualified Data.Text as Text
import qualified Data.Set as Set
-- | Hash which uniquely identifies a Unison type or term
newtype Hash = Hash { toBytes :: SBS.ShortByteString } deriving (Eq,Ord,Generic)
instance Show Hash where
show h = take 999 $ Text.unpack (base32Hex h)
instance H.Hashable Hash where
tokens h = [H.Bytes (toByteString h)]
fromByteString :: ByteString -> Hash
fromByteString = fromBytes
toByteString :: Hash -> ByteString
toByteString = SBS.fromShort . toBytes
instance H.Accumulate Hash where
accumulate = fromBytes . BA.convert . CH.hashFinalize . go CH.hashInit where
go :: CH.Context CH.SHA3_512 -> [H.Token Hash] -> CH.Context CH.SHA3_512
go acc tokens = CH.hashUpdates acc (tokens >>= toBS)
toBS (H.Tag b) = [B.singleton b]
toBS (H.Bytes bs) = [encodeLength $ B.length bs, bs]
toBS (H.Int i) = BL.toChunks . toLazyByteString . int64BE $ i
toBS (H.Nat i) = BL.toChunks . toLazyByteString . word64BE $ i
toBS (H.Double d) = BL.toChunks . toLazyByteString . doubleBE $ d
toBS (H.Text txt) =
let tbytes = encodeUtf8 txt
in [encodeLength (B.length tbytes), tbytes]
toBS (H.Hashed h) = [toByteString h]
encodeLength :: Integral n => n -> B.ByteString
encodeLength = BL.toStrict . toLazyByteString . word64BE . fromIntegral
fromBytes = fromByteString
toBytes = toByteString
-- | Return the lowercase unpadded base32Hex encoding of this 'Hash'.
-- Multibase prefix would be 'v', see https://github.com/multiformats/multibase
base32Hex :: Hash -> Text
base32Hex (Hash h)
-- we're using an uppercase encoder that adds padding, so we drop the
-- padding and convert it to lowercase
= Text.toLower
. Text.dropWhileEnd (== '=')
. decodeUtf8
. Base32Hex.encode
$ SBS.fromShort h
validBase32HexChars :: Set Char
validBase32HexChars = Set.fromList $ ['0' .. '9'] ++ ['a' .. 'v']
base32Hex = Base32Hex.toText . Hash.toBase32Hex
-- | Produce a 'Hash' from a base32hex-encoded version of its binary representation
fromBase32Hex :: Text -> Maybe Hash
fromBase32Hex txt = case Base32Hex.decode (encodeUtf8 $ Text.toUpper txt <> paddingChars) of
Left (_, _rem) -> Nothing
Right h -> pure $ Hash (SBS.toShort h)
where
-- The decoder we're using is a base32 uppercase decoder that expects padding,
-- so we provide it with the appropriate number of padding characters for the
-- expected hash length.
--
-- The decoder requires 40 bit (8 5-bit characters) chunks, so if the number
-- of characters of the input is not a multiple of 8, we add '=' padding chars
-- until it is.
--
-- See https://tools.ietf.org/html/rfc4648#page-8
paddingChars :: Text
paddingChars = case Text.length txt `mod` 8 of
0 -> ""
n -> Text.replicate (8 - n) "="
fromBase32Hex = fmap Hash.fromBase32Hex . Base32Hex.fromText
hashLength :: Int
hashLength = 512
_paddingChars :: Text
_paddingChars = case hashLength `mod` 40 of
0 -> ""
8 -> "======"
16 -> "===="
24 -> "==="
32 -> "="
i -> error $ "impossible hash length `mod` 40 not in {0,8,16,24,32}: " <> show i
base32Hexs :: Hash -> String
base32Hexs = Text.unpack . base32Hex
unsafeFromBase32Hex :: Text -> Hash
unsafeFromBase32Hex txt =
fromMaybe (error $ "invalid base32Hex value: " ++ Text.unpack txt) $ fromBase32Hex txt
fromBytes :: ByteString -> Hash
fromBytes = Hash . SBS.toShort
showBase32Hex :: H.Hashable t => t -> String
showBase32Hex = base32Hexs . H.accumulate'
validBase32HexChars :: Set Char
validBase32HexChars = Base32Hex.validChars

33
unison-core/src/Unison/Hashable.hs
View File

@ -2,14 +2,22 @@ module Unison.Hashable where
import Unison.Prelude
import qualified Crypto.Hash as CH
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.ByteString.Builder (doubleBE, int64BE, toLazyByteString, word64BE)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified U.Util.Hash as H
import Unison.Util.Relation (Relation)
import Unison.Util.Relation3 (Relation3)
import Unison.Util.Relation4 (Relation4)
import qualified Unison.Util.Relation as Relation
import Unison.Util.Relation3 (Relation3)
import qualified Unison.Util.Relation3 as Relation3
import Unison.Util.Relation4 (Relation4)
import qualified Unison.Util.Relation4 as Relation4
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
data Token h
= Tag !Word8
@ -107,3 +115,24 @@ instance Hashable Int64 where
instance Hashable Bool where
tokens b = [Tag . fromIntegral $ fromEnum b]
instance Hashable Hash where
tokens h = [Bytes (Hash.toByteString h)]
instance Accumulate Hash where
accumulate = fromBytes . BA.convert . CH.hashFinalize . go CH.hashInit where
go :: CH.Context CH.SHA3_512 -> [Token Hash] -> CH.Context CH.SHA3_512
go acc tokens = CH.hashUpdates acc (tokens >>= toBS)
toBS (Tag b) = [B.singleton b]
toBS (Bytes bs) = [encodeLength $ B.length bs, bs]
toBS (Int i) = BL.toChunks . toLazyByteString . int64BE $ i
toBS (Nat i) = BL.toChunks . toLazyByteString . word64BE $ i
toBS (Double d) = BL.toChunks . toLazyByteString . doubleBE $ d
toBS (Text txt) =
let tbytes = encodeUtf8 txt
in [encodeLength (B.length tbytes), tbytes]
toBS (Hashed h) = [H.toByteString h]
encodeLength :: Integral n => n -> B.ByteString
encodeLength = BL.toStrict . toLazyByteString . word64BE . fromIntegral
fromBytes = H.fromByteString
toBytes = H.toByteString

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

@ -968,7 +968,8 @@ etaNormalForm :: Ord v => Term0 v -> Term0 v
etaNormalForm tm = case tm of
LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body
where
step (LamNamed' v (App' f (Var' v'))) | v == v' = f
step (LamNamed' v (App' f (Var' v')))
| v == v' , v `Set.notMember` freeVars f = f
step tm = tm
_ -> tm
@ -977,8 +978,9 @@ etaReduceEtaVars :: Var v => Term0 v -> Term0 v
etaReduceEtaVars tm = case tm of
LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body
where
ok v v' = v == v' && Var.typeOf v == Var.Eta
step (LamNamed' v (App' f (Var' v'))) | ok v v' = f
ok v v' f = v == v' && Var.typeOf v == Var.Eta
&& v `Set.notMember` freeVars f
step (LamNamed' v (App' f (Var' v'))) | ok v v' f = f
step tm = tm
_ -> tm

2
unison-core/unison-core1.cabal
View File

@ -99,10 +99,10 @@ library
, prelude-extras
, rfc5051
, safe
, sandi
, text
, transformers
, unison-prelude
, unison-util
, unison-util-relation
, util
, vector

2
unison-src/transcripts/dependents-dependencies-debugfile.output.md
View File

@ -47,7 +47,7 @@ But wait, there's more. I can check the dependencies and dependents of a defini
.> dependents q
#l5pndeifuh doesn't have any dependents.
#l5pndeifuh doesn't have any named dependents.
.> dependencies q

14
unison-src/transcripts/fix2156.md Normal file
View File

@ -0,0 +1,14 @@
Tests for a case where bad eta reduction was causing erroneous watch
output/caching.
```ucm:hide
.> builtins.merge
```
```unison
sqr : Nat -> Nat
sqr n = n * n
> sqr
```

29
unison-src/transcripts/fix2156.output.md Normal file
View File

@ -0,0 +1,29 @@
Tests for a case where bad eta reduction was causing erroneous watch
output/caching.
```unison
sqr : Nat -> Nat
sqr n = n * n
> sqr
```
```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`:
sqr : Nat -> Nat
Now evaluating any watch expressions (lines starting with
`>`)... Ctrl+C cancels.
4 | > sqr
⧩
n -> n Nat.* n
```