From 26338d89df4fcad79171a75f96be32034faf48bb Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 13 Aug 2021 20:10:44 -0500 Subject: [PATCH 001/148] compression builtins --- parser-typechecker/package.yaml | 2 + parser-typechecker/src/Unison/Builtin.hs | 5 + .../src/Unison/Runtime/Builtin.hs | 18 + parser-typechecker/src/Unison/Util/Bytes.hs | 26 +- .../unison-parser-typechecker.cabal | 2 + .../transcripts-using-base/hashing.output.md | 16 +- unison-src/transcripts/alias-many.output.md | 704 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- unison-src/transcripts/builtins.md | 21 + unison-src/transcripts/builtins.output.md | 24 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 14 files changed, 483 insertions(+), 383 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 1df6fe1246..f6b3a34bfc 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -44,6 +44,7 @@ library: - configurator - cryptonite - data-default + - deepseq - directory - either - fuzzyfind @@ -108,6 +109,7 @@ library: - x509 - x509-store - x509-system + - zlib - unison-codebase - unison-codebase-sqlite - unison-codebase-sync diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 28b69aa3bc..de51a29d5d 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -428,6 +428,11 @@ builtinsSrc = , B "Bytes.size" $ bytes --> nat , B "Bytes.flatten" $ bytes --> bytes + , B "Bytes.zlib.compress" $ bytes --> bytes + , B "Bytes.zlib.decompress" $ bytes --> eithert text bytes + , B "Bytes.gzip.compress" $ bytes --> bytes + , B "Bytes.gzip.decompress" $ bytes --> eithert text bytes + {- These are all `Bytes -> Bytes`, rather than `Bytes -> Text`. This is intentional: it avoids a round trip to `Text` if all you are doing with the bytes is dumping them to a file or a diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index d3756f1a49..1c9df33ba6 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -18,6 +18,9 @@ module Unison.Runtime.Builtin ) where import Control.Monad.State.Strict (State, modify, execState) +import qualified Control.Exception.Safe as Exception +import Control.Monad.Catch (MonadCatch) +import Control.DeepSeq (NFData) import Unison.ABT.Normalized hiding (TTm) import Unison.Reference @@ -1786,6 +1789,21 @@ declareForeigns = do in pure . Bytes.fromArray . hmac alg $ serializeValueLazy x + let + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Text.pack (show se)) + Right a -> Right a + + declareForeign "Bytes.zlib.compress" boxDirect . mkForeign $ pure . Bytes.zlibCompress + declareForeign "Bytes.gzip.compress" boxDirect . mkForeign $ pure . Bytes.gzipCompress + declareForeign "Bytes.zlib.decompress" boxToEBoxBox . mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + declareForeign "Bytes.gzip.decompress" boxToEBoxBox . mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + declareForeign "Bytes.toBase16" boxDirect . mkForeign $ pure . Bytes.toBase16 declareForeign "Bytes.toBase32" boxDirect . mkForeign $ pure . Bytes.toBase32 declareForeign "Bytes.toBase64" boxDirect . mkForeign $ pure . Bytes.toBase64 diff --git a/parser-typechecker/src/Unison/Util/Bytes.hs b/parser-typechecker/src/Unison/Util/Bytes.hs index 580c5586ed..c4c5a2a211 100644 --- a/parser-typechecker/src/Unison/Util/Bytes.hs +++ b/parser-typechecker/src/Unison/Util/Bytes.hs @@ -3,6 +3,7 @@ module Unison.Util.Bytes where +import Control.DeepSeq (NFData(..)) import Data.Bits (shiftR, shiftL, (.|.)) import Data.Char import Data.Memory.PtrMethods (memCompare, memEqual) @@ -17,6 +18,8 @@ import qualified Data.ByteArray as B import qualified Data.ByteArray.Encoding as BE import qualified Data.FingerTree as T import qualified Data.Text as Text +import qualified Codec.Compression.Zlib as Zlib +import qualified Codec.Compression.GZip as GZip -- Block is just `newtype Block a = Block ByteArray#` type ByteString = Block Word8 @@ -35,12 +38,27 @@ empty = Bytes mempty fromArray :: B.ByteArrayAccess ba => ba -> Bytes fromArray = snoc empty +zlibCompress :: Bytes -> Bytes +zlibCompress = fromLazyByteString . Zlib.compress . toLazyByteString + +gzipCompress :: Bytes -> Bytes +gzipCompress = fromLazyByteString . GZip.compress . toLazyByteString + +gzipDecompress :: Bytes -> Bytes +gzipDecompress = fromLazyByteString . GZip.decompress . toLazyByteString + +zlibDecompress :: Bytes -> Bytes +zlibDecompress = fromLazyByteString . Zlib.decompress . toLazyByteString + toArray :: forall bo . B.ByteArray bo => Bytes -> bo toArray b = B.concat (map B.convert (chunks b) :: [bo]) toLazyByteString :: Bytes -> LB.ByteString toLazyByteString b = LB.fromChunks $ map B.convert $ chunks b +fromLazyByteString :: LB.ByteString -> Bytes +fromLazyByteString b = fromChunks (map (view . B.convert) $ LB.toChunks b) + size :: Bytes -> Int size (Bytes bs) = getSum (T.measure bs) @@ -212,7 +230,7 @@ fillBE :: Word64 -> Int -> Ptr Word8 -> IO () fillBE n 0 p = poke p (fromIntegral n) >> return () fillBE n i p = poke p (fromIntegral (shiftR n (i * 8))) >> fillBE n (i - 1) (p `plusPtr` 1) - + encodeNat64be :: Word64 -> Bytes encodeNat64be n = Bytes (T.singleton (view (B.unsafeCreate 8 (fillBE n 7)))) @@ -361,3 +379,9 @@ instance B.ByteArrayAccess bytes => B.ByteArrayAccess (View bytes) where length = viewSize withByteArray v f = B.withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v)) + +instance NFData (View bs) where + rnf bs = seq bs () + +instance NFData Bytes where + rnf bs = rnf (chunks bs) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 2b14bbb8ef..3beb2ace6f 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -193,6 +193,7 @@ library , cryptonite , data-default , data-memocombinators + , deepseq , directory , either , errors @@ -260,6 +261,7 @@ library , x509 , x509-store , x509-system + , zlib if flag(optimized) ghc-options: -funbox-strict-fields -O2 default-language: Haskell2010 diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index 2f8c322478..a79fe660ce 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -27,13 +27,15 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.w 20. fromBase64 (Bytes -> Either Text Bytes) 21. fromBase64UrlUnpadded (Bytes -> Either Text Bytes) 22. fromList ([Nat] -> Bytes) - 23. size (Bytes -> Nat) - 24. take (Nat -> Bytes -> Bytes) - 25. toBase16 (Bytes -> Bytes) - 26. toBase32 (Bytes -> Bytes) - 27. toBase64 (Bytes -> Bytes) - 28. toBase64UrlUnpadded (Bytes -> Bytes) - 29. toList (Bytes -> [Nat]) + 23. gzip/ (2 definitions) + 24. size (Bytes -> Nat) + 25. take (Nat -> Bytes -> Bytes) + 26. toBase16 (Bytes -> Bytes) + 27. toBase32 (Bytes -> Bytes) + 28. toBase64 (Bytes -> Bytes) + 29. toBase64UrlUnpadded (Bytes -> Bytes) + 30. toList (Bytes -> [Nat]) + 31. zlib/ (2 definitions) ``` Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`. diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index bac4662806..c4c76a9776 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -46,404 +46,408 @@ Let's try it! 26. Bytes.fromBase64 : Bytes -> Either Text Bytes 27. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes 28. Bytes.fromList : [Nat] -> Bytes - 29. Bytes.size : Bytes -> Nat - 30. Bytes.take : Nat -> Bytes -> Bytes - 31. Bytes.toBase16 : Bytes -> Bytes - 32. Bytes.toBase32 : Bytes -> Bytes - 33. Bytes.toBase64 : Bytes -> Bytes - 34. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 35. Bytes.toList : Bytes -> [Nat] - 36. builtin type Char - 37. Char.fromNat : Nat -> Char - 38. Char.toNat : Char -> Nat - 39. Char.toText : Char -> Text - 40. builtin type Code - 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 42. Code.dependencies : Code -> [Term] - 43. Code.deserialize : Bytes -> Either Text Code - 44. Code.isMissing : Term ->{IO} Boolean - 45. Code.lookup : Term ->{IO} Optional Code - 46. Code.serialize : Code -> Bytes - 47. crypto.hash : HashAlgorithm -> a -> Bytes - 48. builtin type crypto.HashAlgorithm - 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 58. crypto.hmacBytes : HashAlgorithm + 29. Bytes.gzip.compress : Bytes -> Bytes + 30. Bytes.gzip.decompress : Bytes -> Either Text Bytes + 31. Bytes.size : Bytes -> Nat + 32. Bytes.take : Nat -> Bytes -> Bytes + 33. Bytes.toBase16 : Bytes -> Bytes + 34. Bytes.toBase32 : Bytes -> Bytes + 35. Bytes.toBase64 : Bytes -> Bytes + 36. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 37. Bytes.toList : Bytes -> [Nat] + 38. Bytes.zlib.compress : Bytes -> Bytes + 39. Bytes.zlib.decompress : Bytes -> Either Text Bytes + 40. builtin type Char + 41. Char.fromNat : Nat -> Char + 42. Char.toNat : Char -> Nat + 43. Char.toText : Char -> Text + 44. builtin type Code + 45. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 46. Code.dependencies : Code -> [Term] + 47. Code.deserialize : Bytes -> Either Text Code + 48. Code.isMissing : Term ->{IO} Boolean + 49. Code.lookup : Term ->{IO} Optional Code + 50. Code.serialize : Code -> Bytes + 51. crypto.hash : HashAlgorithm -> a -> Bytes + 52. builtin type crypto.HashAlgorithm + 53. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 54. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 55. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 56. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 57. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 58. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 59. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 60. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 61. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 62. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 59. Debug.watch : Text -> a -> a - 60. unique type Doc - 61. Doc.Blob : Text -> Doc - 62. Doc.Evaluate : Term -> Doc - 63. Doc.Join : [Doc] -> Doc - 64. Doc.Link : Link -> Doc - 65. Doc.Signature : Term -> Doc - 66. Doc.Source : Link -> Doc - 67. type Either a b - 68. Either.Left : a -> Either a b - 69. Either.Right : b -> Either a b - 70. ability Exception - 71. Exception.raise : Failure ->{Exception} x - 72. builtin type Float - 73. Float.* : Float -> Float -> Float - 74. Float.+ : Float -> Float -> Float - 75. Float.- : Float -> Float -> Float - 76. Float./ : Float -> Float -> Float - 77. Float.abs : Float -> Float - 78. Float.acos : Float -> Float - 79. Float.acosh : Float -> Float - 80. Float.asin : Float -> Float - 81. Float.asinh : Float -> Float - 82. Float.atan : Float -> Float - 83. Float.atan2 : Float -> Float -> Float - 84. Float.atanh : Float -> Float - 85. Float.ceiling : Float -> Int - 86. Float.cos : Float -> Float - 87. Float.cosh : Float -> Float - 88. Float.eq : Float -> Float -> Boolean - 89. Float.exp : Float -> Float - 90. Float.floor : Float -> Int - 91. Float.fromText : Text -> Optional Float - 92. Float.gt : Float -> Float -> Boolean - 93. Float.gteq : Float -> Float -> Boolean - 94. Float.log : Float -> Float - 95. Float.logBase : Float -> Float -> Float - 96. Float.lt : Float -> Float -> Boolean - 97. Float.lteq : Float -> Float -> Boolean - 98. Float.max : Float -> Float -> Float - 99. Float.min : Float -> Float -> Float - 100. Float.pow : Float -> Float -> Float - 101. Float.round : Float -> Int - 102. Float.sin : Float -> Float - 103. Float.sinh : Float -> Float - 104. Float.sqrt : Float -> Float - 105. Float.tan : Float -> Float - 106. Float.tanh : Float -> Float - 107. Float.toText : Float -> Text - 108. Float.truncate : Float -> Int - 109. builtin type Int - 110. Int.* : Int -> Int -> Int - 111. Int.+ : Int -> Int -> Int - 112. Int.- : Int -> Int -> Int - 113. Int./ : Int -> Int -> Int - 114. Int.and : Int -> Int -> Int - 115. Int.complement : Int -> Int - 116. Int.eq : Int -> Int -> Boolean - 117. Int.fromText : Text -> Optional Int - 118. Int.gt : Int -> Int -> Boolean - 119. Int.gteq : Int -> Int -> Boolean - 120. Int.increment : Int -> Int - 121. Int.isEven : Int -> Boolean - 122. Int.isOdd : Int -> Boolean - 123. Int.leadingZeros : Int -> Nat - 124. Int.lt : Int -> Int -> Boolean - 125. Int.lteq : Int -> Int -> Boolean - 126. Int.mod : Int -> Int -> Int - 127. Int.negate : Int -> Int - 128. Int.or : Int -> Int -> Int - 129. Int.popCount : Int -> Nat - 130. Int.pow : Int -> Nat -> Int - 131. Int.shiftLeft : Int -> Nat -> Int - 132. Int.shiftRight : Int -> Nat -> Int - 133. Int.signum : Int -> Int - 134. Int.toFloat : Int -> Float - 135. Int.toText : Int -> Text - 136. Int.trailingZeros : Int -> Nat - 137. Int.truncate0 : Int -> Nat - 138. Int.xor : Int -> Int -> Int - 139. unique type io2.BufferMode - 140. io2.BufferMode.BlockBuffering : BufferMode - 141. io2.BufferMode.LineBuffering : BufferMode - 142. io2.BufferMode.NoBuffering : BufferMode - 143. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 144. unique type io2.Failure - 145. io2.Failure.Failure : Type -> Text -> Any -> Failure - 146. unique type io2.FileMode - 147. io2.FileMode.Append : FileMode - 148. io2.FileMode.Read : FileMode - 149. io2.FileMode.ReadWrite : FileMode - 150. io2.FileMode.Write : FileMode - 151. builtin type io2.Handle - 152. builtin type io2.IO - 153. io2.IO.clientSocket.impl : Text + 63. Debug.watch : Text -> a -> a + 64. unique type Doc + 65. Doc.Blob : Text -> Doc + 66. Doc.Evaluate : Term -> Doc + 67. Doc.Join : [Doc] -> Doc + 68. Doc.Link : Link -> Doc + 69. Doc.Signature : Term -> Doc + 70. Doc.Source : Link -> Doc + 71. type Either a b + 72. Either.Left : a -> Either a b + 73. Either.Right : b -> Either a b + 74. ability Exception + 75. Exception.raise : Failure ->{Exception} x + 76. builtin type Float + 77. Float.* : Float -> Float -> Float + 78. Float.+ : Float -> Float -> Float + 79. Float.- : Float -> Float -> Float + 80. Float./ : Float -> Float -> Float + 81. Float.abs : Float -> Float + 82. Float.acos : Float -> Float + 83. Float.acosh : Float -> Float + 84. Float.asin : Float -> Float + 85. Float.asinh : Float -> Float + 86. Float.atan : Float -> Float + 87. Float.atan2 : Float -> Float -> Float + 88. Float.atanh : Float -> Float + 89. Float.ceiling : Float -> Int + 90. Float.cos : Float -> Float + 91. Float.cosh : Float -> Float + 92. Float.eq : Float -> Float -> Boolean + 93. Float.exp : Float -> Float + 94. Float.floor : Float -> Int + 95. Float.fromText : Text -> Optional Float + 96. Float.gt : Float -> Float -> Boolean + 97. Float.gteq : Float -> Float -> Boolean + 98. Float.log : Float -> Float + 99. Float.logBase : Float -> Float -> Float + 100. Float.lt : Float -> Float -> Boolean + 101. Float.lteq : Float -> Float -> Boolean + 102. Float.max : Float -> Float -> Float + 103. Float.min : Float -> Float -> Float + 104. Float.pow : Float -> Float -> Float + 105. Float.round : Float -> Int + 106. Float.sin : Float -> Float + 107. Float.sinh : Float -> Float + 108. Float.sqrt : Float -> Float + 109. Float.tan : Float -> Float + 110. Float.tanh : Float -> Float + 111. Float.toText : Float -> Text + 112. Float.truncate : Float -> Int + 113. builtin type Int + 114. Int.* : Int -> Int -> Int + 115. Int.+ : Int -> Int -> Int + 116. Int.- : Int -> Int -> Int + 117. Int./ : Int -> Int -> Int + 118. Int.and : Int -> Int -> Int + 119. Int.complement : Int -> Int + 120. Int.eq : Int -> Int -> Boolean + 121. Int.fromText : Text -> Optional Int + 122. Int.gt : Int -> Int -> Boolean + 123. Int.gteq : Int -> Int -> Boolean + 124. Int.increment : Int -> Int + 125. Int.isEven : Int -> Boolean + 126. Int.isOdd : Int -> Boolean + 127. Int.leadingZeros : Int -> Nat + 128. Int.lt : Int -> Int -> Boolean + 129. Int.lteq : Int -> Int -> Boolean + 130. Int.mod : Int -> Int -> Int + 131. Int.negate : Int -> Int + 132. Int.or : Int -> Int -> Int + 133. Int.popCount : Int -> Nat + 134. Int.pow : Int -> Nat -> Int + 135. Int.shiftLeft : Int -> Nat -> Int + 136. Int.shiftRight : Int -> Nat -> Int + 137. Int.signum : Int -> Int + 138. Int.toFloat : Int -> Float + 139. Int.toText : Int -> Text + 140. Int.trailingZeros : Int -> Nat + 141. Int.truncate0 : Int -> Nat + 142. Int.xor : Int -> Int -> Int + 143. unique type io2.BufferMode + 144. io2.BufferMode.BlockBuffering : BufferMode + 145. io2.BufferMode.LineBuffering : BufferMode + 146. io2.BufferMode.NoBuffering : BufferMode + 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 148. unique type io2.Failure + 149. io2.Failure.Failure : Type -> Text -> Any -> Failure + 150. unique type io2.FileMode + 151. io2.FileMode.Append : FileMode + 152. io2.FileMode.Read : FileMode + 153. io2.FileMode.ReadWrite : FileMode + 154. io2.FileMode.Write : FileMode + 155. builtin type io2.Handle + 156. builtin type io2.IO + 157. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 154. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 155. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 156. io2.IO.createDirectory.impl : Text + 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 160. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 157. io2.IO.createTempDirectory.impl : Text + 161. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 158. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 159. io2.IO.directoryContents.impl : Text + 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 163. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 160. io2.IO.fileExists.impl : Text + 164. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 161. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 162. io2.IO.getBuffering.impl : Handle + 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 166. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 163. io2.IO.getBytes.impl : Handle + 167. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 164. io2.IO.getCurrentDirectory.impl : '{IO} Either + 168. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 165. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 166. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 167. io2.IO.getFileTimestamp.impl : Text + 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 171. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 168. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 169. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 170. io2.IO.handlePosition.impl : Handle + 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 174. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 171. io2.IO.isDirectory.impl : Text + 175. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 172. io2.IO.isFileEOF.impl : Handle + 176. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 173. io2.IO.isFileOpen.impl : Handle + 177. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 174. io2.IO.isSeekable.impl : Handle + 178. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 175. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 176. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 177. io2.IO.openFile.impl : Text + 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 181. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 178. io2.IO.putBytes.impl : Handle + 182. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 179. io2.IO.removeDirectory.impl : Text + 183. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 180. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 181. io2.IO.renameDirectory.impl : Text + 184. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 185. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 182. io2.IO.renameFile.impl : Text + 186. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 183. io2.IO.seekHandle.impl : Handle + 187. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 184. io2.IO.serverSocket.impl : Optional Text + 188. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 185. io2.IO.setBuffering.impl : Handle + 189. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 186. io2.IO.setCurrentDirectory.impl : Text + 190. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 187. io2.IO.socketAccept.impl : Socket + 191. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 188. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 189. io2.IO.socketReceive.impl : Socket + 192. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 193. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 190. io2.IO.socketSend.impl : Socket + 194. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 191. io2.IO.stdHandle : StdHandle -> Handle - 192. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 193. unique type io2.IOError - 194. io2.IOError.AlreadyExists : IOError - 195. io2.IOError.EOF : IOError - 196. io2.IOError.IllegalOperation : IOError - 197. io2.IOError.NoSuchThing : IOError - 198. io2.IOError.PermissionDenied : IOError - 199. io2.IOError.ResourceBusy : IOError - 200. io2.IOError.ResourceExhausted : IOError - 201. io2.IOError.UserError : IOError - 202. unique type io2.IOFailure - 203. builtin type io2.MVar - 204. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 205. io2.MVar.new : a ->{IO} MVar a - 206. io2.MVar.newEmpty : '{IO} MVar a - 207. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 208. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 209. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 210. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 211. io2.MVar.tryPut.impl : MVar a + 195. io2.IO.stdHandle : StdHandle -> Handle + 196. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 197. unique type io2.IOError + 198. io2.IOError.AlreadyExists : IOError + 199. io2.IOError.EOF : IOError + 200. io2.IOError.IllegalOperation : IOError + 201. io2.IOError.NoSuchThing : IOError + 202. io2.IOError.PermissionDenied : IOError + 203. io2.IOError.ResourceBusy : IOError + 204. io2.IOError.ResourceExhausted : IOError + 205. io2.IOError.UserError : IOError + 206. unique type io2.IOFailure + 207. builtin type io2.MVar + 208. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 209. io2.MVar.new : a ->{IO} MVar a + 210. io2.MVar.newEmpty : '{IO} MVar a + 211. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 212. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 213. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 214. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 215. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 212. io2.MVar.tryRead.impl : MVar a + 216. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 213. io2.MVar.tryTake : MVar a ->{IO} Optional a - 214. unique type io2.SeekMode - 215. io2.SeekMode.AbsoluteSeek : SeekMode - 216. io2.SeekMode.RelativeSeek : SeekMode - 217. io2.SeekMode.SeekFromEnd : SeekMode - 218. builtin type io2.Socket - 219. unique type io2.StdHandle - 220. io2.StdHandle.StdErr : StdHandle - 221. io2.StdHandle.StdIn : StdHandle - 222. io2.StdHandle.StdOut : StdHandle - 223. builtin type io2.STM - 224. io2.STM.atomically : '{STM} a ->{IO} a - 225. io2.STM.retry : '{STM} a - 226. builtin type io2.ThreadId - 227. builtin type io2.Tls - 228. builtin type io2.Tls.Cipher - 229. builtin type io2.Tls.ClientConfig - 230. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 217. io2.MVar.tryTake : MVar a ->{IO} Optional a + 218. unique type io2.SeekMode + 219. io2.SeekMode.AbsoluteSeek : SeekMode + 220. io2.SeekMode.RelativeSeek : SeekMode + 221. io2.SeekMode.SeekFromEnd : SeekMode + 222. builtin type io2.Socket + 223. unique type io2.StdHandle + 224. io2.StdHandle.StdErr : StdHandle + 225. io2.StdHandle.StdIn : StdHandle + 226. io2.StdHandle.StdOut : StdHandle + 227. builtin type io2.STM + 228. io2.STM.atomically : '{STM} a ->{IO} a + 229. io2.STM.retry : '{STM} a + 230. builtin type io2.ThreadId + 231. builtin type io2.Tls + 232. builtin type io2.Tls.Cipher + 233. builtin type io2.Tls.ClientConfig + 234. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 231. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 235. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 232. io2.Tls.ClientConfig.default : Text + 236. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 233. io2.Tls.ClientConfig.versions.set : [Version] + 237. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 234. io2.Tls.decodeCert.impl : Bytes + 238. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 235. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 236. io2.Tls.encodeCert : SignedCert -> Bytes - 237. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 238. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 239. io2.Tls.newClient.impl : ClientConfig + 239. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 240. io2.Tls.encodeCert : SignedCert -> Bytes + 241. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 242. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 243. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 240. io2.Tls.newServer.impl : ServerConfig + 244. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 241. builtin type io2.Tls.PrivateKey - 242. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 243. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 244. builtin type io2.Tls.ServerConfig - 245. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 245. builtin type io2.Tls.PrivateKey + 246. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 247. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 248. builtin type io2.Tls.ServerConfig + 249. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 246. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 250. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 247. io2.Tls.ServerConfig.default : [SignedCert] + 251. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 248. io2.Tls.ServerConfig.versions.set : [Version] + 252. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 249. builtin type io2.Tls.SignedCert - 250. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 251. builtin type io2.Tls.Version - 252. unique type io2.TlsFailure - 253. builtin type io2.TVar - 254. io2.TVar.new : a ->{STM} TVar a - 255. io2.TVar.newIO : a ->{IO} TVar a - 256. io2.TVar.read : TVar a ->{STM} a - 257. io2.TVar.readIO : TVar a ->{IO} a - 258. io2.TVar.swap : TVar a -> a ->{STM} a - 259. io2.TVar.write : TVar a -> a ->{STM} () - 260. unique type IsPropagated - 261. IsPropagated.IsPropagated : IsPropagated - 262. unique type IsTest - 263. IsTest.IsTest : IsTest - 264. unique type Link - 265. builtin type Link.Term - 266. Link.Term : Term -> Link - 267. builtin type Link.Type - 268. Link.Type : Type -> Link - 269. builtin type List - 270. List.++ : [a] -> [a] -> [a] - 271. List.+: : a -> [a] -> [a] - 272. List.:+ : [a] -> a -> [a] - 273. List.at : Nat -> [a] -> Optional a - 274. List.cons : a -> [a] -> [a] - 275. List.drop : Nat -> [a] -> [a] - 276. List.empty : [a] - 277. List.size : [a] -> Nat - 278. List.snoc : [a] -> a -> [a] - 279. List.take : Nat -> [a] -> [a] - 280. metadata.isPropagated : IsPropagated - 281. metadata.isTest : IsTest - 282. builtin type Nat - 283. Nat.* : Nat -> Nat -> Nat - 284. Nat.+ : Nat -> Nat -> Nat - 285. Nat./ : Nat -> Nat -> Nat - 286. Nat.and : Nat -> Nat -> Nat - 287. Nat.complement : Nat -> Nat - 288. Nat.drop : Nat -> Nat -> Nat - 289. Nat.eq : Nat -> Nat -> Boolean - 290. Nat.fromText : Text -> Optional Nat - 291. Nat.gt : Nat -> Nat -> Boolean - 292. Nat.gteq : Nat -> Nat -> Boolean - 293. Nat.increment : Nat -> Nat - 294. Nat.isEven : Nat -> Boolean - 295. Nat.isOdd : Nat -> Boolean - 296. Nat.leadingZeros : Nat -> Nat - 297. Nat.lt : Nat -> Nat -> Boolean - 298. Nat.lteq : Nat -> Nat -> Boolean - 299. Nat.mod : Nat -> Nat -> Nat - 300. Nat.or : Nat -> Nat -> Nat - 301. Nat.popCount : Nat -> Nat - 302. Nat.pow : Nat -> Nat -> Nat - 303. Nat.shiftLeft : Nat -> Nat -> Nat - 304. Nat.shiftRight : Nat -> Nat -> Nat - 305. Nat.sub : Nat -> Nat -> Int - 306. Nat.toFloat : Nat -> Float - 307. Nat.toInt : Nat -> Int - 308. Nat.toText : Nat -> Text - 309. Nat.trailingZeros : Nat -> Nat - 310. Nat.xor : Nat -> Nat -> Nat - 311. type Optional a - 312. Optional.None : Optional a - 313. Optional.Some : a -> Optional a - 314. builtin type Request - 315. type SeqView a b - 316. SeqView.VElem : a -> b -> SeqView a b - 317. SeqView.VEmpty : SeqView a b - 318. unique type Test.Result - 319. Test.Result.Fail : Text -> Result - 320. Test.Result.Ok : Text -> Result - 321. builtin type Text - 322. Text.!= : Text -> Text -> Boolean - 323. Text.++ : Text -> Text -> Text - 324. Text.drop : Nat -> Text -> Text - 325. Text.empty : Text - 326. Text.eq : Text -> Text -> Boolean - 327. Text.fromCharList : [Char] -> Text - 328. Text.fromUtf8.impl : Bytes -> Either Failure Text - 329. Text.gt : Text -> Text -> Boolean - 330. Text.gteq : Text -> Text -> Boolean - 331. Text.lt : Text -> Text -> Boolean - 332. Text.lteq : Text -> Text -> Boolean - 333. Text.repeat : Nat -> Text -> Text - 334. Text.size : Text -> Nat - 335. Text.take : Nat -> Text -> Text - 336. Text.toCharList : Text -> [Char] - 337. Text.toUtf8 : Text -> Bytes - 338. Text.uncons : Text -> Optional (Char, Text) - 339. Text.unsnoc : Text -> Optional (Text, Char) - 340. todo : a -> b - 341. type Tuple a b - 342. Tuple.Cons : a -> b -> Tuple a b - 343. type Unit - 344. Unit.Unit : () - 345. Universal.< : a -> a -> Boolean - 346. Universal.<= : a -> a -> Boolean - 347. Universal.== : a -> a -> Boolean - 348. Universal.> : a -> a -> Boolean - 349. Universal.>= : a -> a -> Boolean - 350. Universal.compare : a -> a -> Int - 351. builtin type Value - 352. Value.dependencies : Value -> [Term] - 353. Value.deserialize : Bytes -> Either Text Value - 354. Value.load : Value ->{IO} Either [Term] a - 355. Value.serialize : Value -> Bytes - 356. Value.value : a -> Value + 253. builtin type io2.Tls.SignedCert + 254. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 255. builtin type io2.Tls.Version + 256. unique type io2.TlsFailure + 257. builtin type io2.TVar + 258. io2.TVar.new : a ->{STM} TVar a + 259. io2.TVar.newIO : a ->{IO} TVar a + 260. io2.TVar.read : TVar a ->{STM} a + 261. io2.TVar.readIO : TVar a ->{IO} a + 262. io2.TVar.swap : TVar a -> a ->{STM} a + 263. io2.TVar.write : TVar a -> a ->{STM} () + 264. unique type IsPropagated + 265. IsPropagated.IsPropagated : IsPropagated + 266. unique type IsTest + 267. IsTest.IsTest : IsTest + 268. unique type Link + 269. builtin type Link.Term + 270. Link.Term : Term -> Link + 271. builtin type Link.Type + 272. Link.Type : Type -> Link + 273. builtin type List + 274. List.++ : [a] -> [a] -> [a] + 275. List.+: : a -> [a] -> [a] + 276. List.:+ : [a] -> a -> [a] + 277. List.at : Nat -> [a] -> Optional a + 278. List.cons : a -> [a] -> [a] + 279. List.drop : Nat -> [a] -> [a] + 280. List.empty : [a] + 281. List.size : [a] -> Nat + 282. List.snoc : [a] -> a -> [a] + 283. List.take : Nat -> [a] -> [a] + 284. metadata.isPropagated : IsPropagated + 285. metadata.isTest : IsTest + 286. builtin type Nat + 287. Nat.* : Nat -> Nat -> Nat + 288. Nat.+ : Nat -> Nat -> Nat + 289. Nat./ : Nat -> Nat -> Nat + 290. Nat.and : Nat -> Nat -> Nat + 291. Nat.complement : Nat -> Nat + 292. Nat.drop : Nat -> Nat -> Nat + 293. Nat.eq : Nat -> Nat -> Boolean + 294. Nat.fromText : Text -> Optional Nat + 295. Nat.gt : Nat -> Nat -> Boolean + 296. Nat.gteq : Nat -> Nat -> Boolean + 297. Nat.increment : Nat -> Nat + 298. Nat.isEven : Nat -> Boolean + 299. Nat.isOdd : Nat -> Boolean + 300. Nat.leadingZeros : Nat -> Nat + 301. Nat.lt : Nat -> Nat -> Boolean + 302. Nat.lteq : Nat -> Nat -> Boolean + 303. Nat.mod : Nat -> Nat -> Nat + 304. Nat.or : Nat -> Nat -> Nat + 305. Nat.popCount : Nat -> Nat + 306. Nat.pow : Nat -> Nat -> Nat + 307. Nat.shiftLeft : Nat -> Nat -> Nat + 308. Nat.shiftRight : Nat -> Nat -> Nat + 309. Nat.sub : Nat -> Nat -> Int + 310. Nat.toFloat : Nat -> Float + 311. Nat.toInt : Nat -> Int + 312. Nat.toText : Nat -> Text + 313. Nat.trailingZeros : Nat -> Nat + 314. Nat.xor : Nat -> Nat -> Nat + 315. type Optional a + 316. Optional.None : Optional a + 317. Optional.Some : a -> Optional a + 318. builtin type Request + 319. type SeqView a b + 320. SeqView.VElem : a -> b -> SeqView a b + 321. SeqView.VEmpty : SeqView a b + 322. unique type Test.Result + 323. Test.Result.Fail : Text -> Result + 324. Test.Result.Ok : Text -> Result + 325. builtin type Text + 326. Text.!= : Text -> Text -> Boolean + 327. Text.++ : Text -> Text -> Text + 328. Text.drop : Nat -> Text -> Text + 329. Text.empty : Text + 330. Text.eq : Text -> Text -> Boolean + 331. Text.fromCharList : [Char] -> Text + 332. Text.fromUtf8.impl : Bytes -> Either Failure Text + 333. Text.gt : Text -> Text -> Boolean + 334. Text.gteq : Text -> Text -> Boolean + 335. Text.lt : Text -> Text -> Boolean + 336. Text.lteq : Text -> Text -> Boolean + 337. Text.repeat : Nat -> Text -> Text + 338. Text.size : Text -> Nat + 339. Text.take : Nat -> Text -> Text + 340. Text.toCharList : Text -> [Char] + 341. Text.toUtf8 : Text -> Bytes + 342. Text.uncons : Text -> Optional (Char, Text) + 343. Text.unsnoc : Text -> Optional (Text, Char) + 344. todo : a -> b + 345. type Tuple a b + 346. Tuple.Cons : a -> b -> Tuple a b + 347. type Unit + 348. Unit.Unit : () + 349. Universal.< : a -> a -> Boolean + 350. Universal.<= : a -> a -> Boolean + 351. Universal.== : a -> a -> Boolean + 352. Universal.> : a -> a -> Boolean + 353. Universal.>= : a -> a -> Boolean + 354. Universal.compare : a -> a -> Int + 355. builtin type Value + 356. Value.dependencies : Value -> [Term] + 357. Value.deserialize : Bytes -> Either Text Value + 358. Value.load : Value ->{IO} Either [Term] a + 359. Value.serialize : Value -> Bytes + 360. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -452,17 +456,17 @@ Let's try it! Added definitions: - 1. Float.log : Float -> Float - 2. Float.logBase : Float -> Float -> Float - 3. Float.lt : Float -> Float -> Boolean - 4. Float.lteq : Float -> Float -> Boolean - 5. Float.max : Float -> Float -> Float - 6. Float.min : Float -> Float -> Float - 7. Float.pow : Float -> Float -> Float - 8. Float.round : Float -> Int - 9. Float.sin : Float -> Float - 10. Float.sinh : Float -> Float - 11. Float.sqrt : Float -> Float + 1. Float.floor : Float -> Int + 2. Float.fromText : Text -> Optional Float + 3. Float.gt : Float -> Float -> Boolean + 4. Float.gteq : Float -> Float -> Boolean + 5. Float.log : Float -> Float + 6. Float.logBase : Float -> Float -> Float + 7. Float.lt : Float -> Float -> Boolean + 8. Float.lteq : Float -> Float -> Boolean + 9. Float.max : Float -> Float -> Float + 10. Float.min : Float -> Float -> Float + 11. Float.pow : Float -> Float -> Float Tip: You can use `undo` or `reflog` to undo this change. @@ -522,17 +526,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.log : Float -> Float - 2. Float.logBase : Float -> Float -> Float - 3. Float.lt : Float -> Float -> Boolean - 4. Float.lteq : Float -> Float -> Boolean - 5. Float.max : Float -> Float -> Float - 6. Float.min : Float -> Float -> Float - 7. Float.pow : Float -> Float -> Float - 8. Float.round : Float -> Int - 9. Float.sin : Float -> Float - 10. Float.sinh : Float -> Float - 11. Float.sqrt : Float -> Float + 1. Float.floor : Float -> Int + 2. Float.fromText : Text -> Optional Float + 3. Float.gt : Float -> Float -> Boolean + 4. Float.gteq : Float -> Float -> Boolean + 5. Float.log : Float -> Float + 6. Float.logBase : Float -> Float -> Float + 7. Float.lt : Float -> Float -> Boolean + 8. Float.lteq : Float -> Float -> Boolean + 9. Float.max : Float -> Float -> Float + 10. Float.min : Float -> Float -> Float + 11. Float.pow : Float -> Float -> Float 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index a699b85331..46c87f7e1a 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -14,7 +14,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 3. Boolean (builtin type) 4. Boolean/ (1 definition) 5. Bytes (builtin type) - 6. Bytes/ (29 definitions) + 6. Bytes/ (33 definitions) 7. Char (builtin type) 8. Char/ (3 definitions) 9. Code (builtin type) diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md index 8352af1586..d1bebbb37d 100644 --- a/unison-src/transcripts/builtins.md +++ b/unison-src/transcripts/builtins.md @@ -227,6 +227,27 @@ test> Bytes.tests.at = Bytes.at 0 bs == Some 77, Bytes.at 99 bs == None ] + +test> Bytes.tests.compression = + roundTrip b = + (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) + && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) + + isLeft = cases + Left _ -> true + Right _ -> false + + checks [ + roundTrip 0xs2093487509823745709827345789023457892345, + roundTrip 0xs00000000000000000000000000000000000000000000, + roundTrip 0xs, + roundTrip 0xs11111111111111111111111111, + roundTrip 0xsffffffffffffffffffffffffffffff, + roundTrip 0xs222222222fffffffffffffffffffffffffffffff, + -- these fail due to bad checksums and/or headers + isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), + isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) + ] ``` ```ucm:hide diff --git a/unison-src/transcripts/builtins.output.md b/unison-src/transcripts/builtins.output.md index b83798518a..416b1f1ccf 100644 --- a/unison-src/transcripts/builtins.output.md +++ b/unison-src/transcripts/builtins.output.md @@ -204,6 +204,27 @@ test> Bytes.tests.at = Bytes.at 0 bs == Some 77, Bytes.at 99 bs == None ] + +test> Bytes.tests.compression = + roundTrip b = + (Bytes.zlib.decompress (Bytes.zlib.compress b) == Right b) + && (Bytes.gzip.decompress (Bytes.gzip.compress b) == Right b) + + isLeft = cases + Left _ -> true + Right _ -> false + + checks [ + roundTrip 0xs2093487509823745709827345789023457892345, + roundTrip 0xs00000000000000000000000000000000000000000000, + roundTrip 0xs, + roundTrip 0xs11111111111111111111111111, + roundTrip 0xsffffffffffffffffffffffffffffff, + roundTrip 0xs222222222fffffffffffffffffffffffffffffff, + -- these fail due to bad checksums and/or headers + isLeft (zlib.decompress 0xs2093487509823745709827345789023457892345), + isLeft (gzip.decompress 0xs201209348750982374593939393939709827345789023457892345) + ] ``` ## `Any` functions @@ -257,6 +278,7 @@ Now that all the tests have been added to the codebase, let's view the test repo ◉ Boolean.tests.notTable Passed ◉ Boolean.tests.orTable Passed ◉ Bytes.tests.at Passed + ◉ Bytes.tests.compression Passed ◉ Int.tests.arithmetic Passed ◉ Int.tests.bitTwiddling Passed ◉ Int.tests.conversions Passed @@ -267,7 +289,7 @@ Now that all the tests have been added to the codebase, let's view the test repo ◉ Text.tests.repeat Passed ◉ Text.tests.takeDropAppend Passed - ✅ 15 test(s) passing + ✅ 16 test(s) passing Tip: Use view Any.test1 to view the source of a test. diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index d648c3dcda..27574aefb3 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (356 definitions) + 1. builtin/ (360 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (524 definitions) + 1. builtin/ (528 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 8a23e32681..3a5cfaf003 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #phqs777jj7 + ⊙ #a811qrcopu - Deletes: feature1.y - ⊙ #n77vujo4il + ⊙ #a1p0e4titu + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #msplsg3ueo + ⊙ #ni8uvphkh4 + Adds / updates: feature1.y - ⊙ #9spac4uc55 + ⊙ #tc32iv6qjd > Moves: Original name New name x master.x - ⊙ #grjpiitanv + ⊙ #ek3ga6djgv + Adds / updates: x - □ #l9u7s7kl6v (start of history) + □ #tjol927qko (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index e7c8fcdcd4..95547e772d 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #o8pmeorctm .old` to make an old namespace + `fork #gplos7eiv5 .old` to make an old namespace accessible again, - `reset-root #o8pmeorctm` to reset the root namespace and + `reset-root #gplos7eiv5` to reset the root namespace and its history to that of the specified namespace. - 1. #tolltjdebp : add - 2. #o8pmeorctm : add - 3. #l9u7s7kl6v : builtins.merge + 1. #gk0gksqj3i : add + 2. #gplos7eiv5 : add + 3. #tjol927qko : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index cfbec6c2b7..9b1a1be217 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #od1fl5q84m (start of history) + □ #1i8c436t0p (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #q60575r9ju + ⊙ #3bmnt6nsqc > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #308j638l8k + ⊙ #npl4p8nqhk > Moves: Original name New name Nat.+ Nat.frobnicate - □ #od1fl5q84m (start of history) + □ #1i8c436t0p (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #q60575r9ju + ⊙ #3bmnt6nsqc > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #308j638l8k + ⊙ #npl4p8nqhk > Moves: Original name New name Nat.+ Nat.frobnicate - □ #od1fl5q84m (start of history) + □ #1i8c436t0p (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #od1fl5q84m (start of history) + □ #1i8c436t0p (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #cvsvuk3b0j + ⊙ #pecjlutsl0 - Deletes: Nat.* Nat.+ - □ #od1fl5q84m (start of history) + □ #1i8c436t0p (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 257ae66989062e6f5dcd4d7ed19a9c6760902829 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 20 Aug 2021 14:50:05 -0400 Subject: [PATCH 002/148] Add unsafe.coerceAbilities builtin --- parser-typechecker/src/Unison/Builtin.hs | 19 +++++++ .../src/Unison/Runtime/Builtin.hs | 9 ++++ unison-src/transcripts/alias-many.output.md | 13 ++--- .../transcripts/builtins-merge.output.md | 1 + .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 ++--- unison-src/transcripts/reflog.output.md | 10 ++-- unison-src/transcripts/squash.output.md | 20 +++---- unison-src/transcripts/unsafe-coerce.md | 23 ++++++++ .../transcripts/unsafe-coerce.output.md | 52 +++++++++++++++++++ 10 files changed, 134 insertions(+), 29 deletions(-) create mode 100644 unison-src/transcripts/unsafe-coerce.md create mode 100644 unison-src/transcripts/unsafe-coerce.output.md diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 28b69aa3bc..139147a965 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -458,6 +458,9 @@ builtinsSrc = , B "List.at" $ forall1 "a" (\a -> nat --> list a --> optionalt a) , B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a) + , B "unsafe.coerceAbilities" $ + forall4 "a" "b" "e1" "e2" $ \a b e1 e2 -> + (a --> Type.effect1 () e1 b) --> (a --> Type.effect1 () e2 b) ] ++ -- avoid name conflicts with Universal == < > <= >= [ Rename (t <> "." <> old) (t <> "." <> new) @@ -641,6 +644,22 @@ forall1 name body = a = Var.named name in Type.forall () a (body $ Type.var () a) +forall4 + :: Var v + => Text -> Text -> Text -> Text + -> (Type v -> Type v -> Type v -> Type v -> Type v) + -> Type v +forall4 na nb nc nd body = Type.foralls () [a,b,c,d] (body ta tb tc td) + where + a = Var.named na + b = Var.named nb + c = Var.named nc + d = Var.named nd + ta = Type.var () a + tb = Type.var () b + tc = Type.var () c + td = Type.var () d + app :: Ord v => Type v -> Type v -> Type v app = Type.app () diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index d3756f1a49..6a24df94ca 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -656,6 +656,14 @@ cast ri ro -> unbox x0 ri x $ TCon ro 0 [x] +-- This version of unsafeCoerce is the identity function. It works +-- only if the two types being coerced between are actually the same, +-- because it keeps the same representation. It is not capable of +-- e.g. correctly translating between two types with compatible bit +-- representations, because tagging information will be retained. +poly'coerce :: Var v => SuperNormal v +poly'coerce = unop0 0 $ \[x] -> TVar x + jumpk :: Var v => SuperNormal v jumpk = binop0 0 $ \[k,a] -> TKon k [a] @@ -1360,6 +1368,7 @@ builtinLookup , ("bug", bug "builtin.bug") , ("todo", bug "builtin.todo") , ("Debug.watch", watch) + , ("unsafe.coerceAbilities", poly'coerce) , ("Char.toNat", cast Ty.charRef Ty.natRef) , ("Char.fromNat", cast Ty.natRef Ty.charRef) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index bac4662806..76bc47d5da 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -438,12 +438,13 @@ Let's try it! 348. Universal.> : a -> a -> Boolean 349. Universal.>= : a -> a -> Boolean 350. Universal.compare : a -> a -> Int - 351. builtin type Value - 352. Value.dependencies : Value -> [Term] - 353. Value.deserialize : Bytes -> Either Text Value - 354. Value.load : Value ->{IO} Either [Term] a - 355. Value.serialize : Value -> Bytes - 356. Value.value : a -> Value + 351. unsafe.coerceAbilities : (a -> b) -> a -> b + 352. builtin type Value + 353. Value.dependencies : Value -> [Term] + 354. Value.deserialize : Bytes -> Either Text Value + 355. Value.load : Value ->{IO} Either [Term] a + 356. Value.serialize : Value -> Bytes + 357. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index a699b85331..04f241e09f 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -60,5 +60,6 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 49. io2/ (121 definitions) 50. metadata/ (2 definitions) 51. todo (a -> b) + 52. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index d648c3dcda..5a3c023f21 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (356 definitions) + 1. builtin/ (357 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (524 definitions) + 1. builtin/ (525 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 8a23e32681..f1d1e94fa9 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #phqs777jj7 + ⊙ #74nqc89d79 - Deletes: feature1.y - ⊙ #n77vujo4il + ⊙ #tklnrie7ir + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #msplsg3ueo + ⊙ #1h2a8pe8lc + Adds / updates: feature1.y - ⊙ #9spac4uc55 + ⊙ #11sjhkv2a7 > Moves: Original name New name x master.x - ⊙ #grjpiitanv + ⊙ #3jv2tn8jog + Adds / updates: x - □ #l9u7s7kl6v (start of history) + □ #hdn32lqh81 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index e7c8fcdcd4..97f11283c9 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #o8pmeorctm .old` to make an old namespace + `fork #7vu39adpbh .old` to make an old namespace accessible again, - `reset-root #o8pmeorctm` to reset the root namespace and + `reset-root #7vu39adpbh` to reset the root namespace and its history to that of the specified namespace. - 1. #tolltjdebp : add - 2. #o8pmeorctm : add - 3. #l9u7s7kl6v : builtins.merge + 1. #r4k3aok8ct : add + 2. #7vu39adpbh : add + 3. #hdn32lqh81 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index cfbec6c2b7..a93ccf71d2 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #od1fl5q84m (start of history) + □ #461002o629 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #q60575r9ju + ⊙ #eus8fcflv8 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #308j638l8k + ⊙ #samr90cmo9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #od1fl5q84m (start of history) + □ #461002o629 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #q60575r9ju + ⊙ #eus8fcflv8 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #308j638l8k + ⊙ #samr90cmo9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #od1fl5q84m (start of history) + □ #461002o629 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #od1fl5q84m (start of history) + □ #461002o629 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #cvsvuk3b0j + ⊙ #sgaj8rdp8u - Deletes: Nat.* Nat.+ - □ #od1fl5q84m (start of history) + □ #461002o629 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. diff --git a/unison-src/transcripts/unsafe-coerce.md b/unison-src/transcripts/unsafe-coerce.md new file mode 100644 index 0000000000..0a5c5572b1 --- /dev/null +++ b/unison-src/transcripts/unsafe-coerce.md @@ -0,0 +1,23 @@ + +```ucm:hide +.> builtins.mergeio +``` + +```unison +f : '{} Nat +f _ = 5 + +fc : '{IO, Exception} Nat +fc = unsafe.coerceAbilities f + +main : '{IO, Exception} [Result] +main _ = + n = !fc + if n == 5 then [Ok ""] else [Fail ""] +``` + +```ucm +.> find unsafe.coerceAbilities +.> add +.> io.test main +``` diff --git a/unison-src/transcripts/unsafe-coerce.output.md b/unison-src/transcripts/unsafe-coerce.output.md new file mode 100644 index 0000000000..51612ded87 --- /dev/null +++ b/unison-src/transcripts/unsafe-coerce.output.md @@ -0,0 +1,52 @@ + +```unison +f : '{} Nat +f _ = 5 + +fc : '{IO, Exception} Nat +fc = unsafe.coerceAbilities f + +main : '{IO, Exception} [Result] +main _ = + n = !fc + if n == 5 then [Ok ""] else [Fail ""] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] + +``` +```ucm +.> find unsafe.coerceAbilities + + 1. builtin.unsafe.coerceAbilities : (a -> b) -> a -> b + + +.> add + + ⍟ I've added these definitions: + + f : 'Nat + fc : '{IO, Exception} Nat + main : '{IO, Exception} [Result] + +.> io.test main + + New test results: + + ◉ main + + ✅ 1 test(s) passing + + Tip: Use view main to view the source of a test. + +``` From 51e2ea08983689dd0d704f279c5453da5ddae400 Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 23 Aug 2021 13:37:56 -0700 Subject: [PATCH 003/148] Adds structural keyword requirement --- parser-typechecker/src/Unison/DeclPrinter.hs | 2 +- parser-typechecker/src/Unison/FileParser.hs | 53 ++++++++++++-------- parser-typechecker/src/Unison/Lexer.hs | 48 +++++++++++++----- parser-typechecker/src/Unison/Parser.hs | 16 ++++++ parser-typechecker/src/Unison/PrintError.hs | 13 +++++ 5 files changed, 97 insertions(+), 35 deletions(-) diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index e0d98f1f24..8d43dfdc0d 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -157,7 +157,7 @@ fieldNames env r name dd = case DD.constructors dd of _ -> Nothing prettyModifier :: DD.Modifier -> Pretty SyntaxText -prettyModifier DD.Structural = mempty +prettyModifier DD.Structural = fmt S.DataTypeModifier "structural" prettyModifier (DD.Unique _uid) = fmt S.DataTypeModifier "unique" -- <> ("[" <> P.text uid <> "] ") diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index e81a102f08..bceb39a4f7 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -212,18 +212,22 @@ declarations = do [ (v, DD.annotation <$> ds) | (v, ds) <- Map.toList mdsBad ] <> [ (v, DD.annotation . DD.toDataDecl <$> es) | (v, es) <- Map.toList mesBad ] -modifier :: Var v => P v (L.Token DD.Modifier) +-- unique[someguid] type Blah = ... +modifier :: Var v => P v (Maybe (L.Token DD.Modifier)) modifier = do - o <- optional (openBlockWith "unique") - case o of - Nothing -> fmap (const DD.Structural) <$> P.lookAhead anyToken - Just tok -> do + optional (unique <|> structural) + where + unique = do + tok <- openBlockWith "unique" uid <- do o <- optional (reserved "[" *> wordyIdString <* reserved "]") case o of Nothing -> uniqueName 32 Just uid -> pure (fromString . L.payload $ uid) pure (DD.Unique uid <$ tok) + structural = do + tok <- openBlockWith "structural" + pure (DD.Structural <$ tok) declaration :: Var v => P v (Either (v, DataDeclaration v Ann, Accessors v) @@ -235,10 +239,10 @@ declaration = do dataDeclaration :: forall v . Var v - => L.Token DD.Modifier + => Maybe (L.Token DD.Modifier) -> P v (v, DataDeclaration v Ann, Accessors v) dataDeclaration mod = do - _ <- fmap void (reserved "type") <|> openBlockWith "type" + keywordTok <- fmap void (reserved "type") <|> openBlockWith "type" (name, typeArgs) <- (,) <$> TermParser.verifyRelativeVarName prefixDefinitionName <*> many (TermParser.verifyRelativeVarName prefixDefinitionName) @@ -274,16 +278,19 @@ dataDeclaration mod = do -- otherwise ann of name closingAnn :: Ann closingAnn = last (ann eq : ((\(_,_,t) -> ann t) <$> constructors)) - pure (L.payload name, - DD.mkDataDecl' (L.payload mod) (ann mod <> closingAnn) typeArgVs constructors, - accessors) + case mod of + Nothing -> P.customFailure $ MissingTypeModifier ("type" <$ keywordTok) name + Just mod' -> + pure (L.payload name, + DD.mkDataDecl' (L.payload mod') (ann mod' <> closingAnn) typeArgVs constructors, + accessors) effectDeclaration - :: Var v => L.Token DD.Modifier -> P v (v, EffectDeclaration v Ann) + :: Var v => Maybe (L.Token DD.Modifier) -> P v (v, EffectDeclaration v Ann) effectDeclaration mod = do - _ <- fmap void (reserved "ability") <|> openBlockWith "ability" - name <- TermParser.verifyRelativeVarName prefixDefinitionName - typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) + keywordTok <- fmap void (reserved "ability") <|> openBlockWith "ability" + name <- TermParser.verifyRelativeVarName prefixDefinitionName + typeArgs <- many (TermParser.verifyRelativeVarName prefixDefinitionName) let typeArgVs = L.payload <$> typeArgs blockStart <- openBlockWith "where" constructors <- sepBy semi (constructor typeArgs name) @@ -291,13 +298,17 @@ effectDeclaration mod = do _ <- closeBlock <* closeBlock let closingAnn = last $ ann blockStart : ((\(_, _, t) -> ann t) <$> constructors) - pure - ( L.payload name - , DD.mkEffectDecl' (L.payload mod) - (ann mod <> closingAnn) - typeArgVs - constructors - ) + + case mod of + Nothing -> P.customFailure $ MissingTypeModifier ("ability" <$ keywordTok) name + Just mod' -> + pure + ( L.payload name + , DD.mkEffectDecl' (L.payload mod') + (ann mod' <> closingAnn) + typeArgVs + constructors + ) where constructor :: Var v => [L.Token v] -> L.Token v -> P v (Ann, v, Type v Ann) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 12c2fde690..5a2aff4dfc 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -11,6 +11,9 @@ module Unison.Lexer ( escapeChars, debugFileLex, debugLex', debugLex'', debugLex''', showEscapeChar, touches, + typeModifiers, + typeOrAbilityAlt, + typeModifiersAlt, -- todo: these probably don't belong here wordyIdChar, wordyIdStartChar, wordyId, symbolyId, wordyId0, symbolyId0) @@ -330,7 +333,9 @@ lexemes' eof = P.optional space >> do wordyKw kw = separated wordySep (lit kw) subsequentTypeName = P.lookAhead . P.optional $ do let lit' s = lit s <* sp - _ <- P.optional (lit' "unique") *> (wordyKw "type" <|> wordyKw "ability") <* sp + let modifier = typeModifiersAlt lit' + let typeOrAbility' = typeOrAbilityAlt wordyKw + _ <- modifier <* typeOrAbility' *> sp wordyId ignore _ _ _ = [] body = join <$> P.many (sectionElem <* CP.space) @@ -392,7 +397,7 @@ lexemes' eof = P.optional space >> do pure s typeLink = wrap "syntax.docEmbedTypeLink" $ do - _ <- (lit "type" <|> lit "ability") <* CP.space + _ <- typeOrAbilityAlt lit <* CP.space tok (symbolyId <|> wordyId) <* CP.space termLink = wrap "syntax.docEmbedTermLink" $ @@ -792,7 +797,9 @@ lexemes' eof = P.optional space >> do where ifElse = openKw "if" <|> close' (Just "then") ["if"] (lit "then") <|> close' (Just "else") ["then"] (lit "else") - typ = openKw1 wordySep "unique" <|> openTypeKw1 "type" <|> openTypeKw1 "ability" + modKw = typeModifiersAlt (openKw1 wordySep) + typeOrAbilityKw = typeOrAbilityAlt openTypeKw1 + typ = modKw <|> typeOrAbilityKw withKw = do [Token _ pos1 pos2] <- wordyKw "with" @@ -807,12 +814,14 @@ lexemes' eof = P.optional space >> do let opens = [Token (Open "with") pos1 pos2] pure $ replicate n (Token Close pos1 pos2) ++ opens - -- In `unique type` and `unique ability`, only the `unique` opens a layout block, + -- In `structural/unique type` and `structural/unique ability`, + -- only the `structural` or `unique` opens a layout block, -- and `ability` and `type` are just keywords. openTypeKw1 t = do b <- S.gets (topBlockName . layout) - case b of Just "unique" -> wordyKw t - _ -> openKw1 wordySep t + case b of + Just mod | Set.member mod typeModifiers -> wordyKw t + _ -> openKw1 wordySep t -- layout keyword which bumps the layout column by 1, rather than looking ahead -- to the next token to determine the layout column @@ -827,7 +836,7 @@ lexemes' eof = P.optional space >> do env <- S.get case topBlockName (layout env) of -- '=' does not open a layout block if within a type declaration - Just t | t == "type" || t == "unique" -> pure [Token (Reserved "=") start end] + Just t | t == "type" || Set.member t typeModifiers -> pure [Token (Reserved "=") start end] Just _ -> S.put (env { opening = Just "=" }) >> pure [Token (Open "=") start end] _ -> err start LayoutError @@ -981,9 +990,8 @@ reorder :: [T (Token Lexeme)] -> [T (Token Lexeme)] reorder = join . sortWith f . stanzas where f [] = 3 :: Int f (t0 : _) = case payload $ headToken t0 of - Open "type" -> 1 - Open "unique" -> 1 - Open "ability" -> 1 + Open mod | Set.member mod typeModifiers -> 1 + Open typOrA | Set.member typOrA typeOrAbility -> 1 Reserved "use" -> 0 _ -> 3 :: Int @@ -1089,11 +1097,25 @@ symbolyIdChars = Set.fromList "!$%^&*-=+<>.~\\/|:" keywords :: Set String keywords = Set.fromList [ "if", "then", "else", "forall", "∀", - "handle", "with", "unique", + "handle", "with", "where", "use", "true", "false", - "type", "ability", "alias", "typeLink", "termLink", - "let", "namespace", "match", "cases"] + "alias", "typeLink", "termLink", + "let", "namespace", "match", "cases"] <> typeModifiers <> typeOrAbility + +typeOrAbility :: Set String +typeOrAbility = Set.fromList ["type", "ability"] + +typeOrAbilityAlt :: Alternative f => (String -> f a) -> f a +typeOrAbilityAlt f = + asum $ map f (toList typeOrAbility) + +typeModifiers :: Set String +typeModifiers = Set.fromList ["structural", "unique"] + +typeModifiersAlt :: Alternative f => (String -> f a) -> f a +typeModifiersAlt f = + asum $ map f (toList typeModifiers) delimiters :: Set Char delimiters = Set.fromList "()[]{},?;" diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 586ba25ccf..3586cc75c8 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -5,6 +5,20 @@ module Unison.Parser where import Unison.Prelude + ( trace, + join, + foldl', + Text, + optional, + Alternative((<|>), many), + Set, + void, + when, + fromMaybe, + isJust, + listToMaybe, + encodeUtf8, + lastMay ) import qualified Crypto.Random as Random import Data.Bytes.Put (runPutS) @@ -101,6 +115,8 @@ data Error v | UseEmpty (L.Token String) -- an empty `use` statement | DidntExpectExpression (L.Token L.Lexeme) (Maybe (L.Token L.Lexeme)) | TypeDeclarationErrors [UF.Error v Ann] + -- MissingTypeModifier (type|ability) name + | MissingTypeModifier (L.Token String) (L.Token v) | ResolutionFailures [Names.ResolutionFailure v Ann] | DuplicateTypeNames [(v, [Ann])] | DuplicateTermNames [(v, [Ann])] diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index e2c219b0e1..1609f47869 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -69,6 +69,10 @@ pattern Identifier = Color.Bold defaultWidth :: Pr.Width defaultWidth = 60 +-- Various links used in error messages, collected here for a quick overview +structuralVsUniqueDocsLink :: IsString a => Pretty a +structuralVsUniqueDocsLink = "https://www.unisonweb.org/docs/language-reference/#unique-types" + fromOverHere' :: Ord a => String @@ -1287,6 +1291,15 @@ prettyParseError s = \case missing = Set.null referents go (Parser.ResolutionFailures failures) = Pr.border 2 . prettyResolutionFailures s $ failures + go (Parser.MissingTypeModifier keyword name) = Pr.lines + [ Pr.wrap $ + "I expected to see `structural` or `unique` at the start of this line:" + , "" + , tokensAsErrorSite s [void keyword, void name] + , Pr.wrap $ "Learn more about when to use `structural` vs `unique` in the Unison Docs: " + <> structuralVsUniqueDocsLink + ] + unknownConstructor :: String -> L.Token (HashQualified Name) -> Pretty ColorText unknownConstructor ctorType tok = Pr.lines [ From 79ad0fa8dfbce474ad2b8c41a18c88458472cdc9 Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 23 Aug 2021 14:05:37 -0700 Subject: [PATCH 004/148] updates transcripts --- unison-src/transcripts/addupdatemessages.md | 10 +++---- .../transcripts/addupdatemessages.output.md | 30 +++++++++---------- unison-src/transcripts/alias-many.output.md | 12 ++++---- unison-src/transcripts/command-replace.md | 4 +-- unison-src/transcripts/delete.md | 8 ++--- unison-src/transcripts/delete.output.md | 28 ++++++++--------- .../dependents-dependencies-debugfile.md | 8 ++--- ...ependents-dependencies-debugfile.output.md | 14 ++++----- unison-src/transcripts/docs.md | 2 +- unison-src/transcripts/fix1578.md | 6 ++-- unison-src/transcripts/fix1578.output.md | 6 ++-- unison-src/transcripts/fix1696.output.md | 8 +++-- unison-src/transcripts/fix1844.md | 2 +- unison-src/transcripts/fix1844.output.md | 4 +-- unison-src/transcripts/fix2091.md | 2 +- unison-src/transcripts/fix2091.output.md | 4 +-- unison-src/transcripts/fix2254.md | 6 ++-- unison-src/transcripts/lambdacase.md | 2 +- unison-src/transcripts/lambdacase.output.md | 4 +-- unison-src/transcripts/names.md | 2 +- unison-src/transcripts/names.output.md | 2 +- .../top-level-exceptions.output.md | 2 +- 22 files changed, 85 insertions(+), 81 deletions(-) diff --git a/unison-src/transcripts/addupdatemessages.md b/unison-src/transcripts/addupdatemessages.md index 68f7be5a52..8c7e958d47 100644 --- a/unison-src/transcripts/addupdatemessages.md +++ b/unison-src/transcripts/addupdatemessages.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. @@ -25,7 +25,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -type Z = One Nat +structural type Z = One Nat ``` Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. @@ -39,7 +39,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. @@ -52,7 +52,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -type X = Two Nat Nat +structural type X = Two Nat Nat ``` Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. diff --git a/unison-src/transcripts/addupdatemessages.output.md b/unison-src/transcripts/addupdatemessages.output.md index 424c9b08f2..6dc3cfb675 100644 --- a/unison-src/transcripts/addupdatemessages.output.md +++ b/unison-src/transcripts/addupdatemessages.output.md @@ -6,8 +6,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm @@ -18,8 +18,8 @@ type Y = Two Nat Nat ⍟ These new definitions are ok to `add`: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -33,8 +33,8 @@ Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. ⍟ I've added these definitions: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -44,7 +44,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -type Z = One Nat +structural type Z = One Nat ``` ```ucm @@ -55,7 +55,7 @@ type Z = One Nat ⍟ These new definitions are ok to `add`: - type Z + structural type Z (also named X) z : Nat (also named x) @@ -69,7 +69,7 @@ Also, `Z` is an alias for `X`. ⍟ I've added these definitions: - type Z + structural type Z (also named X) z : Nat (also named x) @@ -79,7 +79,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` ```ucm @@ -91,7 +91,7 @@ type X = Three Nat Nat Nat ⍟ These names already exist. You can `update` them to your new definition: - type X + structural type X (The old definition is also named Z. I'll update this name too.) x : Nat @@ -106,7 +106,7 @@ Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old ⍟ I've updated these names to your new definition: - type X + structural type X (The old definition was also named Z. I updated this name too.) x : Nat @@ -118,7 +118,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -type X = Two Nat Nat +structural type X = Two Nat Nat ``` ```ucm @@ -130,7 +130,7 @@ type X = Two Nat Nat ⍟ These names already exist. You can `update` them to your new definition: - type X + structural type X (The old definition is also named Z. I'll update this name too.) (The new definition is already named Y as well.) @@ -147,7 +147,7 @@ Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also ⍟ I've updated these names to your new definition: - type X + structural type X (The old definition was also named Z. I updated this name too.) (The new definition is already named Y as well.) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 32f6be5686..ac69812f1e 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -87,10 +87,10 @@ Let's try it! 64. Doc.Link : Link -> Doc 65. Doc.Signature : Term -> Doc 66. Doc.Source : Link -> Doc - 67. type Either a b + 67. structural type Either a b 68. Either.Left : a -> Either a b 69. Either.Right : b -> Either a b - 70. ability Exception + 70. structural ability Exception 71. Exception.raise : Failure ->{Exception} x 72. builtin type Float 73. Float.* : Float -> Float -> Float @@ -402,11 +402,11 @@ Let's try it! 312. Nat.toText : Nat -> Text 313. Nat.trailingZeros : Nat -> Nat 314. Nat.xor : Nat -> Nat -> Nat - 315. type Optional a + 315. structural type Optional a 316. Optional.None : Optional a 317. Optional.Some : a -> Optional a 318. builtin type Request - 319. type SeqView a b + 319. structural type SeqView a b 320. SeqView.VElem : a -> b -> SeqView a b 321. SeqView.VEmpty : SeqView a b 322. unique type Test.Result @@ -432,9 +432,9 @@ Let's try it! 342. Text.uncons : Text -> Optional (Char, Text) 343. Text.unsnoc : Text -> Optional (Text, Char) 344. todo : a -> b - 345. type Tuple a b + 345. structural type Tuple a b 346. Tuple.Cons : a -> b -> Tuple a b - 347. type Unit + 347. structural type Unit 348. Unit.Unit : () 349. Universal.< : a -> a -> Boolean 350. Universal.<= : a -> a -> Boolean diff --git a/unison-src/transcripts/command-replace.md b/unison-src/transcripts/command-replace.md index 2117e67851..af7af6c946 100644 --- a/unison-src/transcripts/command-replace.md +++ b/unison-src/transcripts/command-replace.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm diff --git a/unison-src/transcripts/delete.md b/unison-src/transcripts/delete.md index 4fcf029d5f..b4a8b01ecf 100644 --- a/unison-src/transcripts/delete.md +++ b/unison-src/transcripts/delete.md @@ -18,7 +18,7 @@ unambiguous type. ```unison:hide foo = 1 -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -60,7 +60,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison:hide -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -68,7 +68,7 @@ type Foo = Foo Nat ``` ```unison:hide -type Foo = Foo Boolean +structural type Foo = Foo Boolean ``` ```ucm @@ -88,7 +88,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison:hide foo = 1 -type foo = Foo Nat +structural type foo = Foo Nat ``` ```ucm diff --git a/unison-src/transcripts/delete.output.md b/unison-src/transcripts/delete.output.md index 45fba4a36e..7570d774f5 100644 --- a/unison-src/transcripts/delete.output.md +++ b/unison-src/transcripts/delete.output.md @@ -18,7 +18,7 @@ unambiguous type. ```unison foo = 1 -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -26,7 +26,7 @@ type Foo = Foo Nat ⍟ I've added these definitions: - type Foo + structural type Foo foo : Nat .> delete foo @@ -41,7 +41,7 @@ type Foo = Foo Nat Removed definitions: - 1. type Foo + 1. structural type Foo Tip: You can use `undo` or `reflog` to undo this change. @@ -128,7 +128,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison -type Foo = Foo Nat +structural type Foo = Foo Nat ``` ```ucm @@ -136,11 +136,11 @@ type Foo = Foo Nat ⍟ I've added these definitions: - type Foo + structural type Foo ``` ```unison -type Foo = Foo Boolean +structural type Foo = Foo Boolean ``` ```ucm @@ -148,7 +148,7 @@ type Foo = Foo Boolean ⍟ I've added these definitions: - type Foo + structural type Foo .a> merge .b @@ -157,12 +157,12 @@ type Foo = Foo Boolean New name conflicts: - 1. type Foo#d97e0jhkmd + 1. structural type Foo#d97e0jhkmd ↓ - 2. ┌ type Foo#d97e0jhkmd + 2. ┌ structural type Foo#d97e0jhkmd - 3. └ type Foo#gq9inhvg9h + 3. └ structural type Foo#gq9inhvg9h 4. Foo.Foo#d97e0jhkmd#0 : Nat -> Foo#d97e0jhkmd @@ -181,7 +181,7 @@ type Foo = Foo Boolean Removed definitions: - 1. type a.Foo#d97e0jhkmd + 1. structural type a.Foo#d97e0jhkmd Name changes: @@ -212,7 +212,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison foo = 1 -type foo = Foo Nat +structural type foo = Foo Nat ``` ```ucm @@ -220,7 +220,7 @@ type foo = Foo Nat ⍟ I've added these definitions: - type foo + structural type foo foo : Nat ``` @@ -229,7 +229,7 @@ type foo = Foo Nat Removed definitions: - 1. type foo + 1. structural type foo 2. foo : Nat Tip: You can use `undo` or `reflog` to undo this change. diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.md b/unison-src/transcripts/dependents-dependencies-debugfile.md index 0bebc6f1cb..46ffce8d30 100644 --- a/unison-src/transcripts/dependents-dependencies-debugfile.md +++ b/unison-src/transcripts/dependents-dependencies-debugfile.md @@ -7,12 +7,12 @@ I can use `debug.file` to see the hashes of the last typechecked file. Given this .u file: ```unison:hide -type outside.A = A Nat outside.B -type outside.B = B Int +structural type outside.A = A Nat outside.B +structural type outside.B = B Int outside.c = 3 outside.d = c < (p + 1) -type inside.M = M outside.A +structural type inside.M = M outside.A inside.p = c inside.q x = x + p * p inside.r = d @@ -35,4 +35,4 @@ But wait, there's more. I can check the dependencies and dependents of a defini .> ``` -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the type that provided the constructor. +We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.output.md b/unison-src/transcripts/dependents-dependencies-debugfile.output.md index 2ee6390d5c..63b00362b3 100644 --- a/unison-src/transcripts/dependents-dependencies-debugfile.output.md +++ b/unison-src/transcripts/dependents-dependencies-debugfile.output.md @@ -3,12 +3,12 @@ I can use `debug.file` to see the hashes of the last typechecked file. Given this .u file: ```unison -type outside.A = A Nat outside.B -type outside.B = B Int +structural type outside.A = A Nat outside.B +structural type outside.B = B Int outside.c = 3 outside.d = c < (p + 1) -type inside.M = M outside.A +structural type inside.M = M outside.A inside.p = c inside.q x = x + p * p inside.r = d @@ -36,9 +36,9 @@ But wait, there's more. I can check the dependencies and dependents of a defini ⍟ I've added these definitions: - type inside.M - type outside.A - type outside.B + structural type inside.M + structural type outside.A + structural type outside.B inside.p : Nat inside.q : Nat -> Nat inside.r : Boolean @@ -90,4 +90,4 @@ But wait, there's more. I can check the dependencies and dependents of a defini 1. #im2kiu2hmn inside.r ``` -We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the type that provided the constructor. +We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/docs.md b/unison-src/transcripts/docs.md index 0ce76d7bab..ccb78f12bc 100644 --- a/unison-src/transcripts/docs.md +++ b/unison-src/transcripts/docs.md @@ -10,7 +10,7 @@ Unison documentation is written in Unison. Documentation is a value of the follo .> view builtin.Doc ``` -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of type `Doc` can be created via syntax like: +You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: ```unison use .builtin diff --git a/unison-src/transcripts/fix1578.md b/unison-src/transcripts/fix1578.md index cf1a35e154..7e825348d4 100644 --- a/unison-src/transcripts/fix1578.md +++ b/unison-src/transcripts/fix1578.md @@ -76,9 +76,9 @@ baz bar = (bar, 42) -- here, `bar` refers to the parameter This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. ```unison:hide -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun -type Day = Day Int +structural type Day = Day Int use Zoot Zonk @@ -96,7 +96,7 @@ day1 = Day +1 Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. ```unison:hide -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun use Zoot Zonk diff --git a/unison-src/transcripts/fix1578.output.md b/unison-src/transcripts/fix1578.output.md index a0ae3d07ed..9ced24641d 100644 --- a/unison-src/transcripts/fix1578.output.md +++ b/unison-src/transcripts/fix1578.output.md @@ -68,9 +68,9 @@ baz bar = (bar, 42) -- here, `bar` refers to the parameter This should also typecheck, using the local `Sun`, and not `Day.Sun` which exists in the codebase, and the local `Day`, not the codebase `Day`. ```unison -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun -type Day = Day Int +structural type Day = Day Int use Zoot Zonk @@ -88,7 +88,7 @@ day1 = Day +1 Even though local definitions are preferred, you can refer to definitions in the codebase via any unique suffix that doesn't also exist in the file. ```unison -type Zoot = Zonk | Sun +structural type Zoot = Zonk | Sun use Zoot Zonk diff --git a/unison-src/transcripts/fix1696.output.md b/unison-src/transcripts/fix1696.output.md index d930247073..c10b4aa859 100644 --- a/unison-src/transcripts/fix1696.output.md +++ b/unison-src/transcripts/fix1696.output.md @@ -19,9 +19,13 @@ dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") ```ucm - The expression in red needs the {Zoot} ability, but this location does not have access to any abilities. + I expected to see `structural` or `unique` at the start of + this line: - 13 | dialog = Ask.provide 'zoot '("Awesome number: " ++ Nat.toText Ask.ask ++ "!") + 1 | ability Ask where ask : Nat + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types ``` diff --git a/unison-src/transcripts/fix1844.md b/unison-src/transcripts/fix1844.md index 9ebd3c27a5..41c189867c 100644 --- a/unison-src/transcripts/fix1844.md +++ b/unison-src/transcripts/fix1844.md @@ -1,6 +1,6 @@ ```unison -type One a = One a +structural type One a = One a unique type Woot a b c = Woot a b c unique type Z = Z diff --git a/unison-src/transcripts/fix1844.output.md b/unison-src/transcripts/fix1844.output.md index 172de373bb..7c9c1f5f3a 100644 --- a/unison-src/transcripts/fix1844.output.md +++ b/unison-src/transcripts/fix1844.output.md @@ -1,6 +1,6 @@ ```unison -type One a = One a +structural type One a = One a unique type Woot a b c = Woot a b c unique type Z = Z @@ -18,7 +18,7 @@ snoc k aN = match k with ⍟ These new definitions are ok to `add`: - type One a + structural type One a unique type Woot a b c unique type Z snoc : One a -> aN -> Woot (One a) (One aN) ##Nat diff --git a/unison-src/transcripts/fix2091.md b/unison-src/transcripts/fix2091.md index aa26776289..1686b9b263 100644 --- a/unison-src/transcripts/fix2091.md +++ b/unison-src/transcripts/fix2091.md @@ -12,7 +12,7 @@ ability'' = 90 -- this type is the same as `type Either a b = Left a | Right b` -- but with very confusing names -- seriously don't ever do this -type type! type_ ability_ = ability' type_ | type! type_ +structural type type! type_ ability_ = ability' type_ | type! type_ unique type type!!! type_ ability_ = ability' type_ | type! type_ ``` diff --git a/unison-src/transcripts/fix2091.output.md b/unison-src/transcripts/fix2091.output.md index 894e2e8734..2e234fbeff 100644 --- a/unison-src/transcripts/fix2091.output.md +++ b/unison-src/transcripts/fix2091.output.md @@ -12,7 +12,7 @@ ability'' = 90 -- this type is the same as `type Either a b = Left a | Right b` -- but with very confusing names -- seriously don't ever do this -type type! type_ ability_ = ability' type_ | type! type_ +structural type type! type_ ability_ = ability' type_ | type! type_ unique type type!!! type_ ability_ = ability' type_ | type! type_ ``` @@ -25,7 +25,7 @@ unique type type!!! type_ ability_ = ability' type_ | type! type_ ⍟ These new definitions are ok to `add`: - type type! type_ ability_ + structural type type! type_ ability_ unique type type!!! type_ ability_ ability! : ##Nat ability'' : ##Nat diff --git a/unison-src/transcripts/fix2254.md b/unison-src/transcripts/fix2254.md index 7e2559f375..95553d65b1 100644 --- a/unison-src/transcripts/fix2254.md +++ b/unison-src/transcripts/fix2254.md @@ -12,7 +12,7 @@ unique type A a b c d | C c | D d -type NeedsA a b = NeedsA (A a b Nat Nat) +structural type NeedsA a b = NeedsA (A a b Nat Nat) | Zoink Text f : A Nat Nat Nat Nat -> Nat @@ -66,7 +66,7 @@ Let's do the update now, and verify that the definitions all look good and there Here's a test of updating a record: ```unison -type Rec = { uno : Nat, dos : Nat } +structural type Rec = { uno : Nat, dos : Nat } combine r = uno r + dos r ``` @@ -76,7 +76,7 @@ combine r = uno r + dos r ``` ```unison -type Rec = { uno : Nat, dos : Nat, tres : Text } +structural type Rec = { uno : Nat, dos : Nat, tres : Text } ``` And checking that after updating this record, there's nothing `todo`: diff --git a/unison-src/transcripts/lambdacase.md b/unison-src/transcripts/lambdacase.md index df546e7289..dcbc2559dc 100644 --- a/unison-src/transcripts/lambdacase.md +++ b/unison-src/transcripts/lambdacase.md @@ -73,7 +73,7 @@ it again shows the definition using the multi-argument `cases` syntax opportunis Here's another example: ```unison -type B = T | F +structural type B = T | F blah = cases T, x -> "hi" diff --git a/unison-src/transcripts/lambdacase.output.md b/unison-src/transcripts/lambdacase.output.md index 79727baed4..9b481c2339 100644 --- a/unison-src/transcripts/lambdacase.output.md +++ b/unison-src/transcripts/lambdacase.output.md @@ -117,7 +117,7 @@ it again shows the definition using the multi-argument `cases` syntax opportunis Here's another example: ```unison -type B = T | F +structural type B = T | F blah = cases T, x -> "hi" @@ -140,7 +140,7 @@ blorf = cases ⍟ These new definitions are ok to `add`: - type B + structural type B blah : B -> B -> Text blorf : B -> B -> B diff --git a/unison-src/transcripts/names.md b/unison-src/transcripts/names.md index 88f405dbf7..dfda4a0c03 100644 --- a/unison-src/transcripts/names.md +++ b/unison-src/transcripts/names.md @@ -4,7 +4,7 @@ ``` ```unison:hide -type IntTriple = IntTriple (Int, Int, Int) +structural type IntTriple = IntTriple (Int, Int, Int) intTriple = IntTriple(+1, +1, +1) ``` diff --git a/unison-src/transcripts/names.output.md b/unison-src/transcripts/names.output.md index 9f9cb40a2f..4e4caa9ae6 100644 --- a/unison-src/transcripts/names.output.md +++ b/unison-src/transcripts/names.output.md @@ -1,6 +1,6 @@ Example uses of the `names` command and output ```unison -type IntTriple = IntTriple (Int, Int, Int) +structural type IntTriple = IntTriple (Int, Int, Int) intTriple = IntTriple(+1, +1, +1) ``` diff --git a/unison-src/transcripts/top-level-exceptions.output.md b/unison-src/transcripts/top-level-exceptions.output.md index 9c052d3f7f..5471c0c461 100644 --- a/unison-src/transcripts/top-level-exceptions.output.md +++ b/unison-src/transcripts/top-level-exceptions.output.md @@ -6,7 +6,7 @@ FYI, here are the `Exception` and `Failure` types: ```ucm .> view Exception Failure - ability builtin.Exception where + structural ability builtin.Exception where raise : Failure ->{builtin.Exception} x unique type builtin.io2.Failure From 5da63ec4f177a4874cb0943460c41a81bdfb4a73 Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 23 Aug 2021 14:09:27 -0700 Subject: [PATCH 005/148] fixes doubleSpace issue --- unison-src/transcripts/addupdatemessages.md | 10 +++++----- unison-src/transcripts/command-replace.md | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/unison-src/transcripts/addupdatemessages.md b/unison-src/transcripts/addupdatemessages.md index 8c7e958d47..671d923ac5 100644 --- a/unison-src/transcripts/addupdatemessages.md +++ b/unison-src/transcripts/addupdatemessages.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -structural type X = One Nat -structural type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. @@ -25,7 +25,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -structural type Z = One Nat +structural type Z = One Nat ``` Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. @@ -39,7 +39,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -structural type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. @@ -52,7 +52,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -structural type X = Two Nat Nat +structural type X = Two Nat Nat ``` Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. diff --git a/unison-src/transcripts/command-replace.md b/unison-src/transcripts/command-replace.md index af7af6c946..1e584529cd 100644 --- a/unison-src/transcripts/command-replace.md +++ b/unison-src/transcripts/command-replace.md @@ -10,8 +10,8 @@ Let's set up some definitions to start: x = 1 y = 2 -structural type X = One Nat -structural type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm From 5fd402d38f3665769a3a265931489105f9e18b3b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 24 Aug 2021 10:15:14 -0400 Subject: [PATCH 006/148] Update stack resolver to LTS Haskell 18.7 Update LTS Haskell 18.7 (the newest, released on 2021-08-20) which includes ghc-8.10.6. More details: https://www.stackage.org/lts-18.7 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 08749cd1e2..1d657ef12c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ packages: - codebase2/util-term #compiler-check: match-exact -resolver: lts-17.15 +resolver: lts-18.7 extra-deps: - github: unisonweb/configurator From 5c0f7deae30e1d3b3e35e66cdc51e91dc2c42d63 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 24 Aug 2021 12:03:16 -0400 Subject: [PATCH 007/148] Add mutable refs in scoped and IO variants --- parser-typechecker/src/Unison/Builtin.hs | 27 ++++++++++++++++++ .../src/Unison/Runtime/Builtin.hs | 28 +++++++++++++++++++ .../src/Unison/Runtime/Foreign.hs | 3 ++ .../src/Unison/Runtime/Foreign/Function.hs | 7 ++++- unison-core/src/Unison/Type.hs | 10 +++++++ 5 files changed, 74 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 6851510654..8d05d76a38 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -179,6 +179,8 @@ builtinTypesSrc = , B' "Tls.Cipher" CT.Data, Rename' "Tls.Cipher" "io2.Tls.Cipher" , B' "TVar" CT.Data, Rename' "TVar" "io2.TVar" , B' "STM" CT.Effect, Rename' "STM" "io2.STM" + , B' "Ref" CT.Data + , B' "Scope" CT.Effect ] -- rename these to "builtin" later, when builtin means intrinsic as opposed to @@ -465,6 +467,14 @@ builtinsSrc = , B "unsafe.coerceAbilities" $ forall4 "a" "b" "e1" "e2" $ \a b e1 e2 -> (a --> Type.effect1 () e1 b) --> (a --> Type.effect1 () e2 b) + , B "Scope.run" . forall2 "r" "g" $ \r g -> + (forall1 "s" $ \s -> unit --> Type.effect () [scopet s, g] r) --> Type.effect1 () g r + , B "Scope.ref" . forall2 "a" "s" $ \a s -> + a --> Type.effect1 () (scopet s) (reft (Type.effects () [scopet s]) a) + , B "Ref.read" . forall2 "a" "g" $ \a g -> + reft g a --> Type.effect1 () g a + , B "Ref.write" . forall2 "a" "g" $ \a g -> + reft g a --> a --> Type.effect1 () g unit ] ++ -- avoid name conflicts with Universal == < > <= >= [ Rename (t <> "." <> old) (t <> "." <> new) @@ -576,6 +586,8 @@ ioBuiltins = , ("IO.delay.impl.v3", nat --> iof unit) , ("IO.kill.impl.v3", threadId --> iof unit) + , ("IO.ref", forall1 "a" $ \a -> + a --> io (reft (Type.effects () [Type.builtinIO ()]) a)) , ("Tls.newClient.impl.v3", tlsClientConfig --> socket --> iof tls) , ("Tls.newServer.impl.v3", tlsServerConfig --> socket --> iof tls) , ("Tls.handshake.impl.v3", tls --> iof unit) @@ -648,6 +660,15 @@ forall1 name body = a = Var.named name in Type.forall () a (body $ Type.var () a) +forall2 + :: Var v => Text -> Text -> (Type v -> Type v -> Type v) -> Type v +forall2 na nb body = Type.foralls () [a,b] (body ta tb) + where + a = Var.named na + b = Var.named nb + ta = Type.var () a + tb = Type.var () b + forall4 :: Var v => Text -> Text -> Text -> Text @@ -694,6 +715,12 @@ failure = DD.failureType () eithert :: Var v => Type v -> Type v -> Type v eithert l r = DD.eitherType () `app` l `app` r +scopet :: Var v => Type v -> Type v +scopet s = Type.scopeType () `app` s + +reft :: Var v => Type v -> Type v -> Type v +reft s a = Type.refType () `app` s `app` a + socket, threadId, handle, unit :: Var v => Type v socket = Type.socket () threadId = Type.threadId () diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 741d08b0e5..2d21623517 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -77,6 +77,12 @@ import Network.Simple.TCP as SYS import Network.TLS as TLS import Network.TLS.Extra.Cipher as Cipher +import Data.IORef as SYS + ( IORef + , newIORef + , readIORef + , writeIORef + ) import System.IO as SYS ( IOMode(..) , openFile @@ -672,6 +678,12 @@ poly'coerce = unop0 0 $ \[x] -> TVar x jumpk :: Var v => SuperNormal v jumpk = binop0 0 $ \[k,a] -> TKon k [a] +scope'run :: Var v => SuperNormal v +scope'run + = unop0 1 $ \[e, un] + -> TLetD un BX (TCon Ty.unitRef 0 []) + $ TApp (FVar e) [un] + fork'comp :: Var v => SuperNormal v fork'comp = Lambda [BX] @@ -1417,6 +1429,8 @@ builtinLookup , ("IO.forkComp.v2", fork'comp) + , ("Scope.run", scope'run) + , ("Code.isMissing", code'missing) , ("Code.cache_", code'cache) , ("Code.lookup", code'lookup) @@ -1620,6 +1634,7 @@ declareForeigns = do declareForeign "MVar.tryRead.impl.v3" boxToEFMBox . mkForeignIOF $ \(mv :: MVar Closure) -> tryReadMVar mv + declareForeign "Char.toText" (wordDirect Ty.charRef) . mkForeign $ \(ch :: Char) -> pure (Text.singleton ch) @@ -1679,6 +1694,19 @@ declareForeigns = do declareForeign "STM.retry" unitDirect . mkForeign $ \() -> unsafeSTMToIO STM.retry :: IO Closure + -- Scope and Ref stuff + declareForeign "Scope.ref" boxDirect + . mkForeign $ \(c :: Closure) -> newIORef c + + declareForeign "IO.ref" boxDirect + . mkForeign $ \(c :: Closure) -> newIORef c + + declareForeign "Ref.read" boxDirect . mkForeign $ + \(r :: IORef Closure) -> readIORef r + + declareForeign "Ref.write" boxBoxTo0 . mkForeign $ + \(r :: IORef Closure, c :: Closure) -> writeIORef r c + let defaultSupported :: TLS.Supported defaultSupported = def { TLS.supportedCiphers = Cipher.ciphersuite_strong } diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index dc7720495d..0991b74e29 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -17,6 +17,7 @@ module Unison.Runtime.Foreign ) where import Control.Concurrent (ThreadId, MVar) +import Data.IORef (IORef) import Data.Text (Text, unpack) import Data.Tagged (Tagged(..)) import Network.Socket (Socket) @@ -47,6 +48,8 @@ ref2eq r -- Note: MVar equality is just reference equality, so it shouldn't -- matter what type the MVar holds. | r == Ty.mvarRef = Just $ promote ((==) @(MVar ())) + -- Ditto + | r == Ty.refRef = Just $ promote ((==) @(IORef ())) | otherwise = Nothing ref2cmp :: Reference -> Maybe (a -> b -> Ordering) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs index 09b86eeda0..826f938357 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs @@ -18,6 +18,7 @@ import Control.Concurrent.MVar (MVar) import Control.Concurrent.STM (TVar) import Control.Exception (evaluate) import qualified Data.Char as Char +import Data.IORef (IORef) import Data.Foldable (toList) import Data.Text (Text, pack, unpack) import Data.Time.Clock.POSIX (POSIXTime) @@ -28,7 +29,7 @@ import System.IO (BufferMode(..), SeekMode, Handle, IOMode) import Unison.Util.Bytes (Bytes) import Unison.Reference (Reference) -import Unison.Type (mvarRef, tvarRef, typeLinkRef) +import Unison.Type (mvarRef, tvarRef, typeLinkRef, refRef) import Unison.Symbol (Symbol) import Unison.Runtime.ANF (SuperGroup, Mem(..), Value, internalBug) @@ -348,6 +349,10 @@ instance ForeignConvention (TVar Closure) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap tvarRef) +instance ForeignConvention (IORef Closure) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap refRef) + instance ForeignConvention (SuperGroup Symbol) where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 6e8862f553..0f59358673 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -227,6 +227,10 @@ filePathRef = Reference.Builtin "FilePath" threadIdRef = Reference.Builtin "ThreadId" socketRef = Reference.Builtin "Socket" +scopeRef, refRef :: Reference +scopeRef = Reference.Builtin "Scope" +refRef = Reference.Builtin "Ref" + mvarRef, tvarRef :: Reference mvarRef = Reference.Builtin "MVar" tvarRef = Reference.Builtin "TVar" @@ -298,6 +302,12 @@ threadId a = ref a threadIdRef builtinIO :: Ord v => a -> Type v a builtinIO a = ref a builtinIORef +scopeType :: Ord v => a -> Type v a +scopeType a = ref a scopeRef + +refType :: Ord v => a -> Type v a +refType a = ref a refRef + socket :: Ord v => a -> Type v a socket a = ref a socketRef From bdd222a0868b1952ebcadc45e311665dcff2f9fd Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 24 Aug 2021 12:20:23 -0400 Subject: [PATCH 008/148] Transcripts - Includes a new test transcript for ref usage --- unison-src/transcripts/alias-many.output.md | 445 +++++++++--------- .../transcripts/builtins-merge.output.md | 71 +-- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/scope-ref.md | 19 + unison-src/transcripts/scope-ref.output.md | 34 ++ unison-src/transcripts/squash.output.md | 20 +- 8 files changed, 340 insertions(+), 275 deletions(-) create mode 100644 unison-src/transcripts/scope-ref.md create mode 100644 unison-src/transcripts/scope-ref.output.md diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 32f6be5686..6478f334e8 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -163,292 +163,299 @@ Let's try it! 140. Int.trailingZeros : Int -> Nat 141. Int.truncate0 : Int -> Nat 142. Int.xor : Int -> Int -> Int - 143. unique type io2.BufferMode - 144. io2.BufferMode.BlockBuffering : BufferMode - 145. io2.BufferMode.LineBuffering : BufferMode - 146. io2.BufferMode.NoBuffering : BufferMode - 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 148. unique type io2.Failure - 149. io2.Failure.Failure : Type -> Text -> Any -> Failure - 150. unique type io2.FileMode - 151. io2.FileMode.Append : FileMode - 152. io2.FileMode.Read : FileMode - 153. io2.FileMode.ReadWrite : FileMode - 154. io2.FileMode.Write : FileMode - 155. builtin type io2.Handle - 156. builtin type io2.IO - 157. io2.IO.clientSocket.impl : Text + 143. IO.ref : a ->{IO} Ref {IO} a + 144. unique type io2.BufferMode + 145. io2.BufferMode.BlockBuffering : BufferMode + 146. io2.BufferMode.LineBuffering : BufferMode + 147. io2.BufferMode.NoBuffering : BufferMode + 148. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 149. unique type io2.Failure + 150. io2.Failure.Failure : Type -> Text -> Any -> Failure + 151. unique type io2.FileMode + 152. io2.FileMode.Append : FileMode + 153. io2.FileMode.Read : FileMode + 154. io2.FileMode.ReadWrite : FileMode + 155. io2.FileMode.Write : FileMode + 156. builtin type io2.Handle + 157. builtin type io2.IO + 158. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 160. io2.IO.createDirectory.impl : Text + 159. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 160. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 161. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 161. io2.IO.createTempDirectory.impl : Text + 162. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 163. io2.IO.directoryContents.impl : Text + 163. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 164. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 164. io2.IO.fileExists.impl : Text + 165. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 166. io2.IO.getBuffering.impl : Handle + 166. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 167. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 167. io2.IO.getBytes.impl : Handle + 168. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 168. io2.IO.getCurrentDirectory.impl : '{IO} Either + 169. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 171. io2.IO.getFileTimestamp.impl : Text + 170. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 171. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 172. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 174. io2.IO.handlePosition.impl : Handle + 173. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 174. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 175. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 175. io2.IO.isDirectory.impl : Text + 176. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 176. io2.IO.isFileEOF.impl : Handle + 177. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 177. io2.IO.isFileOpen.impl : Handle + 178. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isSeekable.impl : Handle + 179. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 181. io2.IO.openFile.impl : Text + 180. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 181. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 182. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 182. io2.IO.putBytes.impl : Handle + 183. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 183. io2.IO.removeDirectory.impl : Text + 184. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 184. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 185. io2.IO.renameDirectory.impl : Text + 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 186. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 186. io2.IO.renameFile.impl : Text + 187. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 187. io2.IO.seekHandle.impl : Handle + 188. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 188. io2.IO.serverSocket.impl : Optional Text + 189. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 189. io2.IO.setBuffering.impl : Handle + 190. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 190. io2.IO.setCurrentDirectory.impl : Text + 191. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 191. io2.IO.socketAccept.impl : Socket + 192. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 192. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 193. io2.IO.socketReceive.impl : Socket + 193. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 194. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 194. io2.IO.socketSend.impl : Socket + 195. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 195. io2.IO.stdHandle : StdHandle -> Handle - 196. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 197. unique type io2.IOError - 198. io2.IOError.AlreadyExists : IOError - 199. io2.IOError.EOF : IOError - 200. io2.IOError.IllegalOperation : IOError - 201. io2.IOError.NoSuchThing : IOError - 202. io2.IOError.PermissionDenied : IOError - 203. io2.IOError.ResourceBusy : IOError - 204. io2.IOError.ResourceExhausted : IOError - 205. io2.IOError.UserError : IOError - 206. unique type io2.IOFailure - 207. builtin type io2.MVar - 208. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 209. io2.MVar.new : a ->{IO} MVar a - 210. io2.MVar.newEmpty : '{IO} MVar a - 211. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 212. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 213. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 214. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 215. io2.MVar.tryPut.impl : MVar a + 196. io2.IO.stdHandle : StdHandle -> Handle + 197. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 198. unique type io2.IOError + 199. io2.IOError.AlreadyExists : IOError + 200. io2.IOError.EOF : IOError + 201. io2.IOError.IllegalOperation : IOError + 202. io2.IOError.NoSuchThing : IOError + 203. io2.IOError.PermissionDenied : IOError + 204. io2.IOError.ResourceBusy : IOError + 205. io2.IOError.ResourceExhausted : IOError + 206. io2.IOError.UserError : IOError + 207. unique type io2.IOFailure + 208. builtin type io2.MVar + 209. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 210. io2.MVar.new : a ->{IO} MVar a + 211. io2.MVar.newEmpty : '{IO} MVar a + 212. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 213. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 214. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 215. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 216. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 216. io2.MVar.tryRead.impl : MVar a + 217. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 217. io2.MVar.tryTake : MVar a ->{IO} Optional a - 218. unique type io2.SeekMode - 219. io2.SeekMode.AbsoluteSeek : SeekMode - 220. io2.SeekMode.RelativeSeek : SeekMode - 221. io2.SeekMode.SeekFromEnd : SeekMode - 222. builtin type io2.Socket - 223. unique type io2.StdHandle - 224. io2.StdHandle.StdErr : StdHandle - 225. io2.StdHandle.StdIn : StdHandle - 226. io2.StdHandle.StdOut : StdHandle - 227. builtin type io2.STM - 228. io2.STM.atomically : '{STM} a ->{IO} a - 229. io2.STM.retry : '{STM} a - 230. builtin type io2.ThreadId - 231. builtin type io2.Tls - 232. builtin type io2.Tls.Cipher - 233. builtin type io2.Tls.ClientConfig - 234. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 218. io2.MVar.tryTake : MVar a ->{IO} Optional a + 219. unique type io2.SeekMode + 220. io2.SeekMode.AbsoluteSeek : SeekMode + 221. io2.SeekMode.RelativeSeek : SeekMode + 222. io2.SeekMode.SeekFromEnd : SeekMode + 223. builtin type io2.Socket + 224. unique type io2.StdHandle + 225. io2.StdHandle.StdErr : StdHandle + 226. io2.StdHandle.StdIn : StdHandle + 227. io2.StdHandle.StdOut : StdHandle + 228. builtin type io2.STM + 229. io2.STM.atomically : '{STM} a ->{IO} a + 230. io2.STM.retry : '{STM} a + 231. builtin type io2.ThreadId + 232. builtin type io2.Tls + 233. builtin type io2.Tls.Cipher + 234. builtin type io2.Tls.ClientConfig + 235. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 235. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 236. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 236. io2.Tls.ClientConfig.default : Text + 237. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 237. io2.Tls.ClientConfig.versions.set : [Version] + 238. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 238. io2.Tls.decodeCert.impl : Bytes + 239. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 239. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 240. io2.Tls.encodeCert : SignedCert -> Bytes - 241. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 242. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 243. io2.Tls.newClient.impl : ClientConfig + 240. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 241. io2.Tls.encodeCert : SignedCert -> Bytes + 242. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 243. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 244. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 244. io2.Tls.newServer.impl : ServerConfig + 245. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 245. builtin type io2.Tls.PrivateKey - 246. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 247. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 248. builtin type io2.Tls.ServerConfig - 249. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 246. builtin type io2.Tls.PrivateKey + 247. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 248. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 249. builtin type io2.Tls.ServerConfig + 250. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 250. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 251. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 251. io2.Tls.ServerConfig.default : [SignedCert] + 252. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 252. io2.Tls.ServerConfig.versions.set : [Version] + 253. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 253. builtin type io2.Tls.SignedCert - 254. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 255. builtin type io2.Tls.Version - 256. unique type io2.TlsFailure - 257. builtin type io2.TVar - 258. io2.TVar.new : a ->{STM} TVar a - 259. io2.TVar.newIO : a ->{IO} TVar a - 260. io2.TVar.read : TVar a ->{STM} a - 261. io2.TVar.readIO : TVar a ->{IO} a - 262. io2.TVar.swap : TVar a -> a ->{STM} a - 263. io2.TVar.write : TVar a -> a ->{STM} () - 264. unique type IsPropagated - 265. IsPropagated.IsPropagated : IsPropagated - 266. unique type IsTest - 267. IsTest.IsTest : IsTest - 268. unique type Link - 269. builtin type Link.Term - 270. Link.Term : Term -> Link - 271. builtin type Link.Type - 272. Link.Type : Type -> Link - 273. builtin type List - 274. List.++ : [a] -> [a] -> [a] - 275. List.+: : a -> [a] -> [a] - 276. List.:+ : [a] -> a -> [a] - 277. List.at : Nat -> [a] -> Optional a - 278. List.cons : a -> [a] -> [a] - 279. List.drop : Nat -> [a] -> [a] - 280. List.empty : [a] - 281. List.size : [a] -> Nat - 282. List.snoc : [a] -> a -> [a] - 283. List.take : Nat -> [a] -> [a] - 284. metadata.isPropagated : IsPropagated - 285. metadata.isTest : IsTest - 286. builtin type Nat - 287. Nat.* : Nat -> Nat -> Nat - 288. Nat.+ : Nat -> Nat -> Nat - 289. Nat./ : Nat -> Nat -> Nat - 290. Nat.and : Nat -> Nat -> Nat - 291. Nat.complement : Nat -> Nat - 292. Nat.drop : Nat -> Nat -> Nat - 293. Nat.eq : Nat -> Nat -> Boolean - 294. Nat.fromText : Text -> Optional Nat - 295. Nat.gt : Nat -> Nat -> Boolean - 296. Nat.gteq : Nat -> Nat -> Boolean - 297. Nat.increment : Nat -> Nat - 298. Nat.isEven : Nat -> Boolean - 299. Nat.isOdd : Nat -> Boolean - 300. Nat.leadingZeros : Nat -> Nat - 301. Nat.lt : Nat -> Nat -> Boolean - 302. Nat.lteq : Nat -> Nat -> Boolean - 303. Nat.mod : Nat -> Nat -> Nat - 304. Nat.or : Nat -> Nat -> Nat - 305. Nat.popCount : Nat -> Nat - 306. Nat.pow : Nat -> Nat -> Nat - 307. Nat.shiftLeft : Nat -> Nat -> Nat - 308. Nat.shiftRight : Nat -> Nat -> Nat - 309. Nat.sub : Nat -> Nat -> Int - 310. Nat.toFloat : Nat -> Float - 311. Nat.toInt : Nat -> Int - 312. Nat.toText : Nat -> Text - 313. Nat.trailingZeros : Nat -> Nat - 314. Nat.xor : Nat -> Nat -> Nat - 315. type Optional a - 316. Optional.None : Optional a - 317. Optional.Some : a -> Optional a - 318. builtin type Request - 319. type SeqView a b - 320. SeqView.VElem : a -> b -> SeqView a b - 321. SeqView.VEmpty : SeqView a b - 322. unique type Test.Result - 323. Test.Result.Fail : Text -> Result - 324. Test.Result.Ok : Text -> Result - 325. builtin type Text - 326. Text.!= : Text -> Text -> Boolean - 327. Text.++ : Text -> Text -> Text - 328. Text.drop : Nat -> Text -> Text - 329. Text.empty : Text - 330. Text.eq : Text -> Text -> Boolean - 331. Text.fromCharList : [Char] -> Text - 332. Text.fromUtf8.impl : Bytes -> Either Failure Text - 333. Text.gt : Text -> Text -> Boolean - 334. Text.gteq : Text -> Text -> Boolean - 335. Text.lt : Text -> Text -> Boolean - 336. Text.lteq : Text -> Text -> Boolean - 337. Text.repeat : Nat -> Text -> Text - 338. Text.size : Text -> Nat - 339. Text.take : Nat -> Text -> Text - 340. Text.toCharList : Text -> [Char] - 341. Text.toUtf8 : Text -> Bytes - 342. Text.uncons : Text -> Optional (Char, Text) - 343. Text.unsnoc : Text -> Optional (Text, Char) - 344. todo : a -> b - 345. type Tuple a b - 346. Tuple.Cons : a -> b -> Tuple a b - 347. type Unit - 348. Unit.Unit : () - 349. Universal.< : a -> a -> Boolean - 350. Universal.<= : a -> a -> Boolean - 351. Universal.== : a -> a -> Boolean - 352. Universal.> : a -> a -> Boolean - 353. Universal.>= : a -> a -> Boolean - 354. Universal.compare : a -> a -> Int - 355. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 356. builtin type Value - 357. Value.dependencies : Value -> [Term] - 358. Value.deserialize : Bytes -> Either Text Value - 359. Value.load : Value ->{IO} Either [Term] a - 360. Value.serialize : Value -> Bytes - 361. Value.value : a -> Value + 254. builtin type io2.Tls.SignedCert + 255. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 256. builtin type io2.Tls.Version + 257. unique type io2.TlsFailure + 258. builtin type io2.TVar + 259. io2.TVar.new : a ->{STM} TVar a + 260. io2.TVar.newIO : a ->{IO} TVar a + 261. io2.TVar.read : TVar a ->{STM} a + 262. io2.TVar.readIO : TVar a ->{IO} a + 263. io2.TVar.swap : TVar a -> a ->{STM} a + 264. io2.TVar.write : TVar a -> a ->{STM} () + 265. unique type IsPropagated + 266. IsPropagated.IsPropagated : IsPropagated + 267. unique type IsTest + 268. IsTest.IsTest : IsTest + 269. unique type Link + 270. builtin type Link.Term + 271. Link.Term : Term -> Link + 272. builtin type Link.Type + 273. Link.Type : Type -> Link + 274. builtin type List + 275. List.++ : [a] -> [a] -> [a] + 276. List.+: : a -> [a] -> [a] + 277. List.:+ : [a] -> a -> [a] + 278. List.at : Nat -> [a] -> Optional a + 279. List.cons : a -> [a] -> [a] + 280. List.drop : Nat -> [a] -> [a] + 281. List.empty : [a] + 282. List.size : [a] -> Nat + 283. List.snoc : [a] -> a -> [a] + 284. List.take : Nat -> [a] -> [a] + 285. metadata.isPropagated : IsPropagated + 286. metadata.isTest : IsTest + 287. builtin type Nat + 288. Nat.* : Nat -> Nat -> Nat + 289. Nat.+ : Nat -> Nat -> Nat + 290. Nat./ : Nat -> Nat -> Nat + 291. Nat.and : Nat -> Nat -> Nat + 292. Nat.complement : Nat -> Nat + 293. Nat.drop : Nat -> Nat -> Nat + 294. Nat.eq : Nat -> Nat -> Boolean + 295. Nat.fromText : Text -> Optional Nat + 296. Nat.gt : Nat -> Nat -> Boolean + 297. Nat.gteq : Nat -> Nat -> Boolean + 298. Nat.increment : Nat -> Nat + 299. Nat.isEven : Nat -> Boolean + 300. Nat.isOdd : Nat -> Boolean + 301. Nat.leadingZeros : Nat -> Nat + 302. Nat.lt : Nat -> Nat -> Boolean + 303. Nat.lteq : Nat -> Nat -> Boolean + 304. Nat.mod : Nat -> Nat -> Nat + 305. Nat.or : Nat -> Nat -> Nat + 306. Nat.popCount : Nat -> Nat + 307. Nat.pow : Nat -> Nat -> Nat + 308. Nat.shiftLeft : Nat -> Nat -> Nat + 309. Nat.shiftRight : Nat -> Nat -> Nat + 310. Nat.sub : Nat -> Nat -> Int + 311. Nat.toFloat : Nat -> Float + 312. Nat.toInt : Nat -> Int + 313. Nat.toText : Nat -> Text + 314. Nat.trailingZeros : Nat -> Nat + 315. Nat.xor : Nat -> Nat -> Nat + 316. type Optional a + 317. Optional.None : Optional a + 318. Optional.Some : a -> Optional a + 319. builtin type Ref + 320. Ref.read : Ref g a ->{g} a + 321. Ref.write : Ref g a -> a ->{g} () + 322. builtin type Request + 323. builtin type Scope + 324. Scope.ref : a ->{Scope s} Ref {Scope s} a + 325. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 326. type SeqView a b + 327. SeqView.VElem : a -> b -> SeqView a b + 328. SeqView.VEmpty : SeqView a b + 329. unique type Test.Result + 330. Test.Result.Fail : Text -> Result + 331. Test.Result.Ok : Text -> Result + 332. builtin type Text + 333. Text.!= : Text -> Text -> Boolean + 334. Text.++ : Text -> Text -> Text + 335. Text.drop : Nat -> Text -> Text + 336. Text.empty : Text + 337. Text.eq : Text -> Text -> Boolean + 338. Text.fromCharList : [Char] -> Text + 339. Text.fromUtf8.impl : Bytes -> Either Failure Text + 340. Text.gt : Text -> Text -> Boolean + 341. Text.gteq : Text -> Text -> Boolean + 342. Text.lt : Text -> Text -> Boolean + 343. Text.lteq : Text -> Text -> Boolean + 344. Text.repeat : Nat -> Text -> Text + 345. Text.size : Text -> Nat + 346. Text.take : Nat -> Text -> Text + 347. Text.toCharList : Text -> [Char] + 348. Text.toUtf8 : Text -> Bytes + 349. Text.uncons : Text -> Optional (Char, Text) + 350. Text.unsnoc : Text -> Optional (Text, Char) + 351. todo : a -> b + 352. type Tuple a b + 353. Tuple.Cons : a -> b -> Tuple a b + 354. type Unit + 355. Unit.Unit : () + 356. Universal.< : a -> a -> Boolean + 357. Universal.<= : a -> a -> Boolean + 358. Universal.== : a -> a -> Boolean + 359. Universal.> : a -> a -> Boolean + 360. Universal.>= : a -> a -> Boolean + 361. Universal.compare : a -> a -> Int + 362. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 363. builtin type Value + 364. Value.dependencies : Value -> [Term] + 365. Value.deserialize : Bytes -> Either Text Value + 366. Value.load : Value ->{IO} Either [Term] a + 367. Value.serialize : Value -> Bytes + 368. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 8ccb61d05b..a54d1519f1 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -28,38 +28,43 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 17. Exception/ (1 definition) 18. Float (builtin type) 19. Float/ (38 definitions) - 20. Int (builtin type) - 21. Int/ (31 definitions) - 22. IsPropagated (type) - 23. IsPropagated/ (1 definition) - 24. IsTest (type) - 25. IsTest/ (1 definition) - 26. Link (type) - 27. Link/ (4 definitions) - 28. List (builtin type) - 29. List/ (10 definitions) - 30. Nat (builtin type) - 31. Nat/ (28 definitions) - 32. Optional (type) - 33. Optional/ (2 definitions) - 34. Request (builtin type) - 35. SeqView (type) - 36. SeqView/ (2 definitions) - 37. Test/ (3 definitions) - 38. Text (builtin type) - 39. Text/ (18 definitions) - 40. Tuple (type) - 41. Tuple/ (1 definition) - 42. Unit (type) - 43. Unit/ (1 definition) - 44. Universal/ (6 definitions) - 45. Value (builtin type) - 46. Value/ (5 definitions) - 47. bug (a -> b) - 48. crypto/ (12 definitions) - 49. io2/ (121 definitions) - 50. metadata/ (2 definitions) - 51. todo (a -> b) - 52. unsafe/ (1 definition) + 20. IO/ (1 definition) + 21. Int (builtin type) + 22. Int/ (31 definitions) + 23. IsPropagated (type) + 24. IsPropagated/ (1 definition) + 25. IsTest (type) + 26. IsTest/ (1 definition) + 27. Link (type) + 28. Link/ (4 definitions) + 29. List (builtin type) + 30. List/ (10 definitions) + 31. Nat (builtin type) + 32. Nat/ (28 definitions) + 33. Optional (type) + 34. Optional/ (2 definitions) + 35. Ref (builtin type) + 36. Ref/ (2 definitions) + 37. Request (builtin type) + 38. Scope (builtin type) + 39. Scope/ (2 definitions) + 40. SeqView (type) + 41. SeqView/ (2 definitions) + 42. Test/ (3 definitions) + 43. Text (builtin type) + 44. Text/ (18 definitions) + 45. Tuple (type) + 46. Tuple/ (1 definition) + 47. Unit (type) + 48. Unit/ (1 definition) + 49. Universal/ (6 definitions) + 50. Value (builtin type) + 51. Value/ (5 definitions) + 52. bug (a -> b) + 53. crypto/ (12 definitions) + 54. io2/ (121 definitions) + 55. metadata/ (2 definitions) + 56. todo (a -> b) + 57. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 6f6cfc46b3..d427631348 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (361 definitions) + 1. builtin/ (368 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (529 definitions) + 1. builtin/ (536 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 0ced5586b9..f38ec66255 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #hbh1v5maor + ⊙ #m7aq1akq80 - Deletes: feature1.y - ⊙ #2l42rrsvar + ⊙ #8orqdkob2u + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #dib06cmchm + ⊙ #21nan08f8m + Adds / updates: feature1.y - ⊙ #l8dl4cfm6g + ⊙ #6r7i9fqova > Moves: Original name New name x master.x - ⊙ #ckfepuvh4m + ⊙ #mlo5c13n51 + Adds / updates: x - □ #u474t1parv (start of history) + □ #0aqhcud35n (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 11bf8e863f..be2c516357 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #no7ag5futf .old` to make an old namespace + `fork #ahc83c1umv .old` to make an old namespace accessible again, - `reset-root #no7ag5futf` to reset the root namespace and + `reset-root #ahc83c1umv` to reset the root namespace and its history to that of the specified namespace. - 1. #m3jpo289fj : add - 2. #no7ag5futf : add - 3. #u474t1parv : builtins.merge + 1. #7fphr69v79 : add + 2. #ahc83c1umv : add + 3. #0aqhcud35n : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/scope-ref.md b/unison-src/transcripts/scope-ref.md new file mode 100644 index 0000000000..691ba7c5f7 --- /dev/null +++ b/unison-src/transcripts/scope-ref.md @@ -0,0 +1,19 @@ + +A short script to test mutable references with local scope. + +```ucm:hide +.> builtins.mergeio +``` + +```unison +test = Scope.run 'let + r = Scope.ref 0 + Ref.write r 1 + i = Ref.read r + Ref.write r 2 + j = Ref.read r + Ref.write r 5 + (i, j, Ref.read r) + +> test +``` diff --git a/unison-src/transcripts/scope-ref.output.md b/unison-src/transcripts/scope-ref.output.md new file mode 100644 index 0000000000..135b2d329c --- /dev/null +++ b/unison-src/transcripts/scope-ref.output.md @@ -0,0 +1,34 @@ + +A short script to test mutable references with local scope. + +```unison +test = Scope.run 'let + r = Scope.ref 0 + Ref.write r 1 + i = Ref.read r + Ref.write r 2 + j = Ref.read r + Ref.write r 5 + (i, j, Ref.read r) + +> test +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + test : (Nat, Nat, Nat) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 10 | > test + ⧩ + (1, 2, 5) + +``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 9ffb067047..06ebd0b3bb 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #rmo1p21ibg (start of history) + □ #qumc45bhl9 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #nd5bbpuhc0 + ⊙ #tg6qv18l8a > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #3sguitlvgr + ⊙ #0viu1h44tq > Moves: Original name New name Nat.+ Nat.frobnicate - □ #rmo1p21ibg (start of history) + □ #qumc45bhl9 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #nd5bbpuhc0 + ⊙ #tg6qv18l8a > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #3sguitlvgr + ⊙ #0viu1h44tq > Moves: Original name New name Nat.+ Nat.frobnicate - □ #rmo1p21ibg (start of history) + □ #qumc45bhl9 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #rmo1p21ibg (start of history) + □ #qumc45bhl9 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #iedv81ls6h + ⊙ #vsss8tgd66 - Deletes: Nat.* Nat.+ - □ #rmo1p21ibg (start of history) + □ #qumc45bhl9 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 52a906441fc55037d80fab116e168de9f6fbc601 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 24 Aug 2021 12:56:51 -0500 Subject: [PATCH 009/148] refresh transcripts --- unison-src/transcripts/alias-many.output.md | 82 +++++++++---------- .../transcripts/builtins-merge.output.md | 75 +++++++++-------- unison-src/transcripts/merges.output.md | 12 +-- unison-src/transcripts/reflog.output.md | 10 +-- unison-src/transcripts/squash.output.md | 20 ++--- 5 files changed, 99 insertions(+), 100 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 6478f334e8..3c48076366 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -163,70 +163,70 @@ Let's try it! 140. Int.trailingZeros : Int -> Nat 141. Int.truncate0 : Int -> Nat 142. Int.xor : Int -> Int -> Int - 143. IO.ref : a ->{IO} Ref {IO} a - 144. unique type io2.BufferMode - 145. io2.BufferMode.BlockBuffering : BufferMode - 146. io2.BufferMode.LineBuffering : BufferMode - 147. io2.BufferMode.NoBuffering : BufferMode - 148. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 149. unique type io2.Failure - 150. io2.Failure.Failure : Type -> Text -> Any -> Failure - 151. unique type io2.FileMode - 152. io2.FileMode.Append : FileMode - 153. io2.FileMode.Read : FileMode - 154. io2.FileMode.ReadWrite : FileMode - 155. io2.FileMode.Write : FileMode - 156. builtin type io2.Handle - 157. builtin type io2.IO - 158. io2.IO.clientSocket.impl : Text + 143. unique type io2.BufferMode + 144. io2.BufferMode.BlockBuffering : BufferMode + 145. io2.BufferMode.LineBuffering : BufferMode + 146. io2.BufferMode.NoBuffering : BufferMode + 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 148. unique type io2.Failure + 149. io2.Failure.Failure : Type -> Text -> Any -> Failure + 150. unique type io2.FileMode + 151. io2.FileMode.Append : FileMode + 152. io2.FileMode.Read : FileMode + 153. io2.FileMode.ReadWrite : FileMode + 154. io2.FileMode.Write : FileMode + 155. builtin type io2.Handle + 156. builtin type io2.IO + 157. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 159. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 160. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 161. io2.IO.createDirectory.impl : Text + 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 160. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 162. io2.IO.createTempDirectory.impl : Text + 161. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 163. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 164. io2.IO.directoryContents.impl : Text + 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 163. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 165. io2.IO.fileExists.impl : Text + 164. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 166. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 167. io2.IO.getBuffering.impl : Handle + 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 166. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 168. io2.IO.getBytes.impl : Handle + 167. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 169. io2.IO.getCurrentDirectory.impl : '{IO} Either + 168. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 170. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 171. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getFileTimestamp.impl : Text + 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 171. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 173. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 174. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 175. io2.IO.handlePosition.impl : Handle + 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 174. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 176. io2.IO.isDirectory.impl : Text + 175. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 177. io2.IO.isFileEOF.impl : Handle + 176. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isFileOpen.impl : Handle + 177. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.isSeekable.impl : Handle + 178. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 180. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 181. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 182. io2.IO.openFile.impl : Text + 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 181. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 183. io2.IO.putBytes.impl : Handle + 182. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () + 183. io2.IO.ref : a ->{IO} Ref {IO} a 184. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index a54d1519f1..c7410c7aa4 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -28,43 +28,42 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 17. Exception/ (1 definition) 18. Float (builtin type) 19. Float/ (38 definitions) - 20. IO/ (1 definition) - 21. Int (builtin type) - 22. Int/ (31 definitions) - 23. IsPropagated (type) - 24. IsPropagated/ (1 definition) - 25. IsTest (type) - 26. IsTest/ (1 definition) - 27. Link (type) - 28. Link/ (4 definitions) - 29. List (builtin type) - 30. List/ (10 definitions) - 31. Nat (builtin type) - 32. Nat/ (28 definitions) - 33. Optional (type) - 34. Optional/ (2 definitions) - 35. Ref (builtin type) - 36. Ref/ (2 definitions) - 37. Request (builtin type) - 38. Scope (builtin type) - 39. Scope/ (2 definitions) - 40. SeqView (type) - 41. SeqView/ (2 definitions) - 42. Test/ (3 definitions) - 43. Text (builtin type) - 44. Text/ (18 definitions) - 45. Tuple (type) - 46. Tuple/ (1 definition) - 47. Unit (type) - 48. Unit/ (1 definition) - 49. Universal/ (6 definitions) - 50. Value (builtin type) - 51. Value/ (5 definitions) - 52. bug (a -> b) - 53. crypto/ (12 definitions) - 54. io2/ (121 definitions) - 55. metadata/ (2 definitions) - 56. todo (a -> b) - 57. unsafe/ (1 definition) + 20. Int (builtin type) + 21. Int/ (31 definitions) + 22. IsPropagated (type) + 23. IsPropagated/ (1 definition) + 24. IsTest (type) + 25. IsTest/ (1 definition) + 26. Link (type) + 27. Link/ (4 definitions) + 28. List (builtin type) + 29. List/ (10 definitions) + 30. Nat (builtin type) + 31. Nat/ (28 definitions) + 32. Optional (type) + 33. Optional/ (2 definitions) + 34. Ref (builtin type) + 35. Ref/ (2 definitions) + 36. Request (builtin type) + 37. Scope (builtin type) + 38. Scope/ (2 definitions) + 39. SeqView (type) + 40. SeqView/ (2 definitions) + 41. Test/ (3 definitions) + 42. Text (builtin type) + 43. Text/ (18 definitions) + 44. Tuple (type) + 45. Tuple/ (1 definition) + 46. Unit (type) + 47. Unit/ (1 definition) + 48. Universal/ (6 definitions) + 49. Value (builtin type) + 50. Value/ (5 definitions) + 51. bug (a -> b) + 52. crypto/ (12 definitions) + 53. io2/ (122 definitions) + 54. metadata/ (2 definitions) + 55. todo (a -> b) + 56. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index f38ec66255..0800365338 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #m7aq1akq80 + ⊙ #nl3sdb3eid - Deletes: feature1.y - ⊙ #8orqdkob2u + ⊙ #nt4hpgmam9 + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #21nan08f8m + ⊙ #hjtrj2kgl4 + Adds / updates: feature1.y - ⊙ #6r7i9fqova + ⊙ #04vktkvglu > Moves: Original name New name x master.x - ⊙ #mlo5c13n51 + ⊙ #0g638hmb59 + Adds / updates: x - □ #0aqhcud35n (start of history) + □ #2f9h2uhlk9 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index be2c516357..c4afd9df17 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #ahc83c1umv .old` to make an old namespace + `fork #3n9h2vkhe3 .old` to make an old namespace accessible again, - `reset-root #ahc83c1umv` to reset the root namespace and + `reset-root #3n9h2vkhe3` to reset the root namespace and its history to that of the specified namespace. - 1. #7fphr69v79 : add - 2. #ahc83c1umv : add - 3. #0aqhcud35n : builtins.merge + 1. #vfl0sjr6kg : add + 2. #3n9h2vkhe3 : add + 3. #2f9h2uhlk9 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 06ebd0b3bb..b81f736d35 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #qumc45bhl9 (start of history) + □ #fhun4m3q9g (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #tg6qv18l8a + ⊙ #565pe56252 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #0viu1h44tq + ⊙ #oavs87p39a > Moves: Original name New name Nat.+ Nat.frobnicate - □ #qumc45bhl9 (start of history) + □ #fhun4m3q9g (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #tg6qv18l8a + ⊙ #565pe56252 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #0viu1h44tq + ⊙ #oavs87p39a > Moves: Original name New name Nat.+ Nat.frobnicate - □ #qumc45bhl9 (start of history) + □ #fhun4m3q9g (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #qumc45bhl9 (start of history) + □ #fhun4m3q9g (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #vsss8tgd66 + ⊙ #jqps95msh5 - Deletes: Nat.* Nat.+ - □ #qumc45bhl9 (start of history) + □ #fhun4m3q9g (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From ac2bc29849b227963042cb41423892ffbbeea192 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 24 Aug 2021 11:33:27 -0700 Subject: [PATCH 010/148] fixes tests and transcripts --- .../src/Unison/Runtime/IOSource.hs | 6 ++-- .../tests/Unison/Test/DataDeclaration.hs | 24 +++++++-------- .../tests/Unison/Test/FileParser.hs | 12 ++++---- .../tests/Unison/Test/GitSync.hs | 6 ++-- .../Unison/Test/Typechecker/TypeError.hs | 2 +- unison-src/Base.u | 6 ++-- unison-src/demo/1.u | 3 +- unison-src/errors/X-array.u | 2 +- .../abort-ability-checks-against-pure.u | 2 +- unison-src/errors/all-errors.u | 6 ++-- .../errors/check-for-regressions/lens.u | 2 +- unison-src/errors/effect-inference1.u | 2 +- unison-src/errors/effect_unknown_type.uu | 2 +- unison-src/errors/handle-inference.u | 2 +- .../errors/handler-coverage-checking.uu | 2 +- unison-src/errors/io-effect.u | 2 +- unison-src/errors/io-state1.u | 4 +-- unison-src/errors/map-traverse3.u | 4 +-- unison-src/errors/need-nominal-type.uu | 4 +-- unison-src/errors/poor-error-message/handle.u | 4 +-- .../errors/poor-error-message/handler-ex.u | 2 +- .../mismatched-case-result-types.u | 2 +- .../errors/poor-error-message/notaguard.u | 2 +- .../overapplied-data-constructor-loc.u | 4 +-- .../poor-error-message/pattern-matching-1.u | 8 ++--- unison-src/errors/state4.u | 2 +- .../errors/term-functor-inspired/effect1.u | 2 +- .../mismatched-case-result-types.u | 2 +- unison-src/errors/type-apply.u | 2 +- .../errors/type-functor-inspired/app2.u | 2 +- .../errors/type-functor-inspired/effect2.u | 4 +-- .../need-nonstructural-types.uu | 4 +-- .../errors/type-functor-inspired/parens.u | 2 +- .../errors/type-functor-inspired/subtuple.u | 2 +- .../errors/type-functor-inspired/tuple.u | 2 +- unison-src/errors/unexpected-loop.u | 2 +- unison-src/errors/unsound-cont.u | 2 +- unison-src/tests/344.uu | 4 +-- unison-src/tests/595.u | 2 +- unison-src/tests/868.u | 4 +-- unison-src/tests/a-tale-of-two-optionals.u | 2 +- unison-src/tests/ability-inference-fail.uu | 4 +-- unison-src/tests/ability-keyword.u | 5 ++-- unison-src/tests/abort.u | 2 +- unison-src/tests/ask-inferred.u | 6 ++-- unison-src/tests/cce.u | 8 ++--- unison-src/tests/console.u | 4 +-- unison-src/tests/console1.u | 4 +-- unison-src/tests/data-references-builtins.u | 2 +- unison-src/tests/delay.u | 2 +- unison-src/tests/delay_parse.u | 2 +- unison-src/tests/effect-instantiation.u | 2 +- unison-src/tests/effect-instantiation2.u | 2 +- unison-src/tests/effect1.u | 2 +- unison-src/tests/fix1185.u | 2 +- unison-src/tests/fix1695.u | 2 +- unison-src/tests/fix528.u | 2 +- unison-src/tests/fix739.u | 2 +- unison-src/tests/force.u | 2 +- unison-src/tests/guard-boolean-operators.u | 2 +- unison-src/tests/handler-stacking.u | 4 +-- unison-src/tests/hang.u | 6 ++-- unison-src/tests/id.u | 3 +- unison-src/tests/if.u | 2 +- unison-src/tests/io-state2.u | 6 ++-- unison-src/tests/io-state3.u | 2 +- unison-src/tests/map-traverse.u | 6 ++-- unison-src/tests/map-traverse2.u | 6 ++-- unison-src/tests/methodical/abilities.u | 6 ++-- .../tests/methodical/apply-constructor.u | 2 +- unison-src/tests/methodical/cycle-minimize.u | 2 +- .../tests/methodical/overapply-ability.u | 2 +- unison-src/tests/multiple-effects.u | 4 +-- unison-src/tests/pattern-matching.u | 10 +++---- unison-src/tests/pattern-matching2.u | 8 ++--- unison-src/tests/pattern-typing-bug.u | 2 +- unison-src/tests/r1.u | 2 +- unison-src/tests/r2.u | 2 +- unison-src/tests/rainbow.u | 4 +-- unison-src/tests/records.u | 6 ++-- .../tests/sequence-literal-argument-parsing.u | 2 +- unison-src/tests/soe.u | 8 ++--- .../tests/spurious-ability-fail-underapply.u | 2 +- unison-src/tests/state1.u | 2 +- unison-src/tests/state1a.u | 2 +- unison-src/tests/state2.u | 2 +- unison-src/tests/state2a-min.u | 2 +- unison-src/tests/state2a.u | 4 +-- unison-src/tests/state2a.uu | 4 +-- unison-src/tests/state2b-min.u | 2 +- unison-src/tests/state2b.u | 4 +-- unison-src/tests/state3.u | 2 +- unison-src/tests/state4.u | 2 +- unison-src/tests/state4a.u | 2 +- unison-src/tests/stream.u | 4 +-- unison-src/tests/stream2.uu | 4 +-- unison-src/tests/stream3.uu | 6 ++-- unison-src/tests/tictactoe.u | 4 +-- unison-src/tests/tictactoe0-array-oob1.u | 2 +- unison-src/tests/tictactoe0-npe.u | 4 +-- unison-src/tests/tictactoe0.u | 4 +-- unison-src/tests/tictactoe2.u | 4 +-- unison-src/tests/type-application.u | 4 +-- unison-src/tests/ungeneralize-bug.uu | 2 +- unison-src/tests/void.u | 2 +- unison-src/transcripts-using-base/base.u | 8 ++--- unison-src/transcripts-using-base/codeops.md | 4 +-- .../transcripts-using-base/codeops.output.md | 12 ++++---- .../transcripts-using-base/doc.output.md | 8 ++--- unison-src/transcripts-using-base/fix2027.md | 4 +-- .../transcripts-using-base/fix2027.output.md | 29 ++++++++----------- .../transcripts-using-base/fix2158-1.md | 2 +- .../fix2158-1.output.md | 4 +-- .../transcripts-using-base/fix2297.output.md | 8 +++-- .../transcripts/addupdatemessages.output.md | 10 +++---- unison-src/transcripts/blocks.md | 8 ++--- unison-src/transcripts/blocks.output.md | 14 ++++----- .../transcripts/bug-strange-closure.output.md | 16 +++++----- .../transcripts/command-replace.output.md | 18 ++++++------ unison-src/transcripts/diff.md | 4 +-- unison-src/transcripts/diff.output.md | 12 ++++---- unison-src/transcripts/docs.output.md | 2 +- unison-src/transcripts/fix1731.md | 2 +- unison-src/transcripts/fix1731.output.md | 2 +- unison-src/transcripts/fix2026.md | 2 +- unison-src/transcripts/fix2026.output.md | 4 +-- unison-src/transcripts/fix2167.md | 2 +- unison-src/transcripts/fix2167.output.md | 4 +-- unison-src/transcripts/fix2238.md | 2 +- unison-src/transcripts/fix2238.output.md | 2 +- unison-src/transcripts/fix2238.u | 2 +- unison-src/transcripts/fix2254.output.md | 27 ++++++++++------- unison-src/transcripts/fix689.md | 2 +- unison-src/transcripts/fix689.output.md | 4 +-- unison-src/transcripts/fix693.md | 4 +-- unison-src/transcripts/fix693.output.md | 12 ++++---- unison-src/transcripts/fix987.md | 2 +- unison-src/transcripts/fix987.output.md | 6 ++-- 138 files changed, 311 insertions(+), 308 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index 44f97a3b36..8ffa58c93b 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -295,9 +295,9 @@ constructorName ref cid = source :: Text source = fromString [r| -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b -type Optional a = None | Some a +structural type Optional a = None | Some a unique[b28d929d0a73d2c18eac86341a3bb9399f8550c11b5f35eabb2751e6803ccc20] type IsPropagated = IsPropagated @@ -462,7 +462,7 @@ unique[d7b2ced8c08b2c6e54050d1f5acedef3395f293d] type Pretty.Annotated w txt | Indent w (Pretty.Annotated w txt) (Pretty.Annotated w txt) (Pretty.Annotated w txt) | Append w [Pretty.Annotated w txt] -type Pretty txt = Pretty (Pretty.Annotated () txt) +structural type Pretty txt = Pretty (Pretty.Annotated () txt) Pretty.get = cases Pretty p -> p diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 40824ecb50..1a11e24d05 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -38,23 +38,23 @@ test = scope "datadeclaration" $ file :: UnisonFile Symbol Ann file = flip unsafeParseFile Common.parsingEnv $ [r| -type Bool = True | False -type Bool' = False | True +structural type Bool = True | False +structural type Bool' = False | True -type Option a = Some a | None -type Option' b = Nothing | Just b +structural type Option a = Some a | None +structural type Option' b = Nothing | Just b -type List a = Nil | Cons a (List a) -type List' b = Prepend b (List' b) | Empty -type SnocList a = Snil | Snoc (List a) a +structural type List a = Nil | Cons a (List a) +structural type List' b = Prepend b (List' b) | Empty +structural type SnocList a = Snil | Snoc (List a) a -type ATree a = Tree a (List (ATree a)) | Leaf (Option a) +structural type ATree a = Tree a (List (ATree a)) | Leaf (Option a) -type Ping a = Ping a (Pong a) -type Pong a = Pnong | Pong (Ping a) +structural type Ping a = Ping a (Pong a) +structural type Pong a = Pnong | Pong (Ping a) -type Long' a = Long' (Ling' a) | Lnong -type Ling' a = Ling' a (Long' a) +structural type Long' a = Long' (Ling' a) | Lnong +structural type Ling' a = Ling' a (Long' a) |] diff --git a/parser-typechecker/tests/Unison/Test/FileParser.hs b/parser-typechecker/tests/Unison/Test/FileParser.hs index f45a6298a6..7120aa4475 100644 --- a/parser-typechecker/tests/Unison/Test/FileParser.hs +++ b/parser-typechecker/tests/Unison/Test/FileParser.hs @@ -18,25 +18,25 @@ module Unison.Test.FileParser where test1 = scope "test1" . tests . map parses $ [ -- , "type () = ()\n()" - "type Pair a b = Pair a b\n" - , "type Optional a = Just a | Nothing\n" + "structural type Pair a b = Pair a b\n" + , "structural type Optional a = Just a | Nothing\n" , unlines - ["type Optional2 a" + ["structural type Optional2 a" ," = Just a" ," | Nothing\n"] ------ -- ,unlines - ------ -- ["type Optional a b c where" + ------ -- ["structural type Optional a b c where" ------ -- ," Just : a -> Optional a" ------ -- ," Nothing : Optional Int"] ------ -- , unlines - ------ -- ["type Optional" + ------ -- ["structural type Optional" ------ -- ," a" ------ -- ," b" ------ -- ," c where" ------ -- ," Just : a -> Optional a" ------ -- ," Nothing : Optional Int"] , unlines -- NB: this currently fails because we don't have type AST or parser for effect types yet - ["ability State s where" + ["structural ability State s where" ," get : {State s} s" ," set : s -> {State s} ()" ] diff --git a/parser-typechecker/tests/Unison/Test/GitSync.hs b/parser-typechecker/tests/Unison/Test/GitSync.hs index a5b4fe88d6..767616ce77 100644 --- a/parser-typechecker/tests/Unison/Test/GitSync.hs +++ b/parser-typechecker/tests/Unison/Test/GitSync.hs @@ -249,7 +249,7 @@ test = scope "gitsync22" . tests $ -- simplest-author (\repo -> [i| ```unison - type Foo = Foo + structural type Foo = Foo ``` ```ucm .myLib> debug.file @@ -322,8 +322,8 @@ test = scope "gitsync22" . tests $ .> builtins.merge ``` ```unison - type A = A Nat - type B = B Int + structural type A = A Nat + structural type B = B Int x = 3 y = 4 ``` diff --git a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs index 5c4b90adb6..60ce8f6c62 100644 --- a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs +++ b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs @@ -32,7 +32,7 @@ test = scope "> extractor" . tests $ , n "> match 3 with 3 | 3 -> 3" Err.matchBody , y "> 1 1" Err.applyingNonFunction , y "> 1 Int.+ 1" Err.applyingFunction - , y ( "ability Abort where\n" ++ + , y ( "structural ability Abort where\n" ++ " abort : {Abort} a\n" ++ "\n" ++ "xyz : t -> Request Abort t -> t\n" ++ diff --git a/unison-src/Base.u b/unison-src/Base.u index a724a43300..98ca0138e8 100644 --- a/unison-src/Base.u +++ b/unison-src/Base.u @@ -154,7 +154,7 @@ List.diagonal = -- -- Use binary search to do lookups and find insertion points -- -- This relies on the underlying sequence having efficient -- -- slicing and concatenation -type Map k v = Map [k] [v] +structural type Map k v = Map [k] [v] -- use Map Map @@ -314,7 +314,7 @@ Multimap.insert k v m = match Map.lookup k m with Multimap.lookup : k -> Map k [v] -> [v] Multimap.lookup k m = Optional.orDefault [] (Map.lookup k m) -type Set a = Set (Map a ()) +structural type Set a = Set (Map a ()) Set.empty : Set k Set.empty = Set Map.empty @@ -346,7 +346,7 @@ Set.size s = Map.size (underlying s) Set.intersect : Set k -> Set k -> Set k Set.intersect s1 s2 = Set (Map.intersect (underlying s1) (underlying s2)) -type Heap k v = Heap Nat k v [Heap k v] +structural type Heap k v = Heap Nat k v [Heap k v] Heap.singleton : k -> v -> Heap k v Heap.singleton k v = Heap 1 k v [] diff --git a/unison-src/demo/1.u b/unison-src/demo/1.u index 02ccb456de..807db03160 100644 --- a/unison-src/demo/1.u +++ b/unison-src/demo/1.u @@ -2,5 +2,4 @@ increment : Nat -> Nat increment n = n + 1 > x = 1 + 40 -> increment x - +> increment x \ No newline at end of file diff --git a/unison-src/errors/X-array.u b/unison-src/errors/X-array.u index 6323617195..9d5d695304 100644 --- a/unison-src/errors/X-array.u +++ b/unison-src/errors/X-array.u @@ -1,4 +1,4 @@ -type X = S Text | I Nat +structural type X = S Text | I Nat foo : a -> b -> c -> X foo x y z = X.S "" diff --git a/unison-src/errors/abort-ability-checks-against-pure.u b/unison-src/errors/abort-ability-checks-against-pure.u index 1d41bf7a1e..9f8c87ae67 100644 --- a/unison-src/errors/abort-ability-checks-against-pure.u +++ b/unison-src/errors/abort-ability-checks-against-pure.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a bork = u -> 1 + (Abort.Abort ()) diff --git a/unison-src/errors/all-errors.u b/unison-src/errors/all-errors.u index 91d44a3e79..ccf865a8a8 100644 --- a/unison-src/errors/all-errors.u +++ b/unison-src/errors/all-errors.u @@ -1,9 +1,9 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a Abort2' : forall a . () -> {Abort2} a diff --git a/unison-src/errors/check-for-regressions/lens.u b/unison-src/errors/check-for-regressions/lens.u index 9a4e4b1cd0..eed7ed9005 100644 --- a/unison-src/errors/check-for-regressions/lens.u +++ b/unison-src/errors/check-for-regressions/lens.u @@ -1,4 +1,4 @@ -type Foo a b = Foo a b +structural type Foo a b = Foo a b use Foo Foo use Optional Some setA : Foo a b -> Optional a -> Foo a b diff --git a/unison-src/errors/effect-inference1.u b/unison-src/errors/effect-inference1.u index d65321e992..dac87a3a0c 100644 --- a/unison-src/errors/effect-inference1.u +++ b/unison-src/errors/effect-inference1.u @@ -1,4 +1,4 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a foo n = if n >= 1000 then n else !Abort.Abort diff --git a/unison-src/errors/effect_unknown_type.uu b/unison-src/errors/effect_unknown_type.uu index 37fb492e4b..f8ff89919f 100755 --- a/unison-src/errors/effect_unknown_type.uu +++ b/unison-src/errors/effect_unknown_type.uu @@ -1,4 +1,4 @@ -ability T where +structural ability T where a : Unknown -> {T} () --b : Unknown diff --git a/unison-src/errors/handle-inference.u b/unison-src/errors/handle-inference.u index 8d5dc87c7a..24354124be 100644 --- a/unison-src/errors/handle-inference.u +++ b/unison-src/errors/handle-inference.u @@ -1,5 +1,5 @@ --handle inference -ability State s where +structural ability State s where get : ∀ s . () -> {State s} s set : ∀ s . s -> {State s} () state : ∀ a s . s -> Request (State s) a -> a diff --git a/unison-src/errors/handler-coverage-checking.uu b/unison-src/errors/handler-coverage-checking.uu index 134519ef01..fe22fb9b06 100644 --- a/unison-src/errors/handler-coverage-checking.uu +++ b/unison-src/errors/handler-coverage-checking.uu @@ -1,5 +1,5 @@ --State3 ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se diff --git a/unison-src/errors/io-effect.u b/unison-src/errors/io-effect.u index 7373163531..f11aad5eae 100644 --- a/unison-src/errors/io-effect.u +++ b/unison-src/errors/io-effect.u @@ -1,5 +1,5 @@ --IO ability -ability IO where +structural ability IO where launchMissiles : () -> {IO} () -- binding is not guarded by a lambda, it only can access -- ambient abilities (which will be empty) diff --git a/unison-src/errors/io-state1.u b/unison-src/errors/io-state1.u index a9d1c11c6a..f37b64402e 100644 --- a/unison-src/errors/io-state1.u +++ b/unison-src/errors/io-state1.u @@ -1,7 +1,7 @@ --IO/State1 ability -ability IO where +structural ability IO where launchMissiles : {IO} () -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se foo : () -> {IO} () diff --git a/unison-src/errors/map-traverse3.u b/unison-src/errors/map-traverse3.u index 724a5bdeee..8db0f0d035 100644 --- a/unison-src/errors/map-traverse3.u +++ b/unison-src/errors/map-traverse3.u @@ -1,8 +1,8 @@ --map/traverse -ability Noop where +structural ability Noop where noop : a -> {Noop} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : (a ->{} b) -> List a -> List b map f = cases diff --git a/unison-src/errors/need-nominal-type.uu b/unison-src/errors/need-nominal-type.uu index 14b48ed3cc..f110f17b92 100644 --- a/unison-src/errors/need-nominal-type.uu +++ b/unison-src/errors/need-nominal-type.uu @@ -1,5 +1,5 @@ -type Foo = Foo -type Bar = Bar +structural type Foo = Foo +structural type Bar = Bar x : Foo x = Bar.Bar diff --git a/unison-src/errors/poor-error-message/handle.u b/unison-src/errors/poor-error-message/handle.u index 6f476f6890..baa69403f8 100644 --- a/unison-src/errors/poor-error-message/handle.u +++ b/unison-src/errors/poor-error-message/handle.u @@ -5,9 +5,9 @@ -- 27 | let -- -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/errors/poor-error-message/handler-ex.u b/unison-src/errors/poor-error-message/handler-ex.u index 9e07c1262c..94c5129b01 100644 --- a/unison-src/errors/poor-error-message/handler-ex.u +++ b/unison-src/errors/poor-error-message/handler-ex.u @@ -11,7 +11,7 @@ -- -- Verbiage could be improved, but also the `()` location should -- point to line 22, the `k ()` call. -ability Ask foo where +structural ability Ask foo where ask : () -> {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/errors/poor-error-message/mismatched-case-result-types.u b/unison-src/errors/poor-error-message/mismatched-case-result-types.u index e1dd520475..aa02487789 100644 --- a/unison-src/errors/poor-error-message/mismatched-case-result-types.u +++ b/unison-src/errors/poor-error-message/mismatched-case-result-types.u @@ -1,5 +1,5 @@ --mismatched case result types -type Optional a = None | Some a +structural type Optional a = None | Some a match Optional.Some 3 with x -> 1 y -> "boo" diff --git a/unison-src/errors/poor-error-message/notaguard.u b/unison-src/errors/poor-error-message/notaguard.u index 54c3f0e373..8c38d07835 100644 --- a/unison-src/errors/poor-error-message/notaguard.u +++ b/unison-src/errors/poor-error-message/notaguard.u @@ -10,7 +10,7 @@ -- -- even though this program doesn't use guards! -ability Ask a where +structural ability Ask a where ask : {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u b/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u index 4f9b25c325..d5e453673c 100644 --- a/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u +++ b/unison-src/errors/poor-error-message/overapplied-data-constructor-loc.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P +structural type Board = Board P P use Board.Board use P O X E diff --git a/unison-src/errors/poor-error-message/pattern-matching-1.u b/unison-src/errors/poor-error-message/pattern-matching-1.u index 2e53532d39..307d94b6cf 100644 --- a/unison-src/errors/poor-error-message/pattern-matching-1.u +++ b/unison-src/errors/poor-error-message/pattern-matching-1.u @@ -1,7 +1,7 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/errors/state4.u b/unison-src/errors/state4.u index b4890f65e7..82b859a75c 100644 --- a/unison-src/errors/state4.u +++ b/unison-src/errors/state4.u @@ -1,5 +1,5 @@ --State4 ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se -- binding is not guarded by a lambda, it only can access diff --git a/unison-src/errors/term-functor-inspired/effect1.u b/unison-src/errors/term-functor-inspired/effect1.u index 1c3f007c35..b072637846 100644 --- a/unison-src/errors/term-functor-inspired/effect1.u +++ b/unison-src/errors/term-functor-inspired/effect1.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where get : () -> {State s} s set : s -> {State s} () diff --git a/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u b/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u index 3aed71fd9f..e72f3be973 100644 --- a/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u +++ b/unison-src/errors/term-functor-inspired/mismatched-case-result-types.u @@ -1,5 +1,5 @@ --mismatched case result types -type Optional a = None | Some a +structural type Optional a = None | Some a match Optional.Some 3 with x -> 1 y -> "boo" diff --git a/unison-src/errors/type-apply.u b/unison-src/errors/type-apply.u index c44b882242..ed179147cf 100644 --- a/unison-src/errors/type-apply.u +++ b/unison-src/errors/type-apply.u @@ -1,5 +1,5 @@ --Type.apply -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : ∀ a b . (a -> b) -> List a -> List b map f = cases List.Nil -> List.Nil diff --git a/unison-src/errors/type-functor-inspired/app2.u b/unison-src/errors/type-functor-inspired/app2.u index b9b422b846..2e9c3e9a4e 100644 --- a/unison-src/errors/type-functor-inspired/app2.u +++ b/unison-src/errors/type-functor-inspired/app2.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None app' : Optional Int app' = 3 () diff --git a/unison-src/errors/type-functor-inspired/effect2.u b/unison-src/errors/type-functor-inspired/effect2.u index 90615b8ea8..1ba2444ccc 100644 --- a/unison-src/errors/type-functor-inspired/effect2.u +++ b/unison-src/errors/type-functor-inspired/effect2.u @@ -1,7 +1,7 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a Abort2' : forall a . () -> {Abort2} a diff --git a/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu b/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu index dc731e635f..a2ad932a78 100644 --- a/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu +++ b/unison-src/errors/type-functor-inspired/need-nonstructural-types.uu @@ -1,7 +1,7 @@ -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a -ability Abort2 where +structural ability Abort2 where Abort2 : forall a . () -> {Abort2} a ability' : Nat -> { Abort } Int diff --git a/unison-src/errors/type-functor-inspired/parens.u b/unison-src/errors/type-functor-inspired/parens.u index 22d02da2db..8d230bb0d4 100644 --- a/unison-src/errors/type-functor-inspired/parens.u +++ b/unison-src/errors/type-functor-inspired/parens.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None y : (Optional Int) y = 3 () \ No newline at end of file diff --git a/unison-src/errors/type-functor-inspired/subtuple.u b/unison-src/errors/type-functor-inspired/subtuple.u index f1aab6f7fd..a8d884af66 100644 --- a/unison-src/errors/type-functor-inspired/subtuple.u +++ b/unison-src/errors/type-functor-inspired/subtuple.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None z' : (Optional Int, Optional Text, Optional Float) z' = (None, 3) diff --git a/unison-src/errors/type-functor-inspired/tuple.u b/unison-src/errors/type-functor-inspired/tuple.u index e7f0019f78..1e957855c3 100644 --- a/unison-src/errors/type-functor-inspired/tuple.u +++ b/unison-src/errors/type-functor-inspired/tuple.u @@ -1,4 +1,4 @@ -type Optional a = Some a | None +structural type Optional a = Some a | None z : (Optional Int, Optional Text, Optional Float) z = 3 () \ No newline at end of file diff --git a/unison-src/errors/unexpected-loop.u b/unison-src/errors/unexpected-loop.u index 16cada0892..175fe1df6f 100644 --- a/unison-src/errors/unexpected-loop.u +++ b/unison-src/errors/unexpected-loop.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a use Nat + diff --git a/unison-src/errors/unsound-cont.u b/unison-src/errors/unsound-cont.u index f05745d9fa..b9d14d1167 100644 --- a/unison-src/errors/unsound-cont.u +++ b/unison-src/errors/unsound-cont.u @@ -1,5 +1,5 @@ -ability Ask a where +structural ability Ask a where ask : {Ask a} a supply : Text -> Request (Ask Text) a -> a diff --git a/unison-src/tests/344.uu b/unison-src/tests/344.uu index 6749329c28..32c12664df 100644 --- a/unison-src/tests/344.uu +++ b/unison-src/tests/344.uu @@ -1,5 +1,5 @@ -ability Either a b where +structural ability Either a b where left : a -> {Either a b} () right : b -> {Either a b} () -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b diff --git a/unison-src/tests/595.u b/unison-src/tests/595.u index b6383b6b58..d8a4eb18f7 100644 --- a/unison-src/tests/595.u +++ b/unison-src/tests/595.u @@ -1,5 +1,5 @@ -type Any = Any (∀ r . (∀ a . a -> r) -> r) +structural type Any = Any (∀ r . (∀ a . a -> r) -> r) -- also typechecks as expected any : a -> Any diff --git a/unison-src/tests/868.u b/unison-src/tests/868.u index 21cef2773a..51866a2191 100644 --- a/unison-src/tests/868.u +++ b/unison-src/tests/868.u @@ -1,5 +1,5 @@ -type Choice = First | Second -type Wrapper = Wrapper Choice +structural type Choice = First | Second +structural type Wrapper = Wrapper Choice broken = match Wrapper.Wrapper Choice.Second with Wrapper.Wrapper Choice.First -> true diff --git a/unison-src/tests/a-tale-of-two-optionals.u b/unison-src/tests/a-tale-of-two-optionals.u index d91fafa6e6..40489216bc 100644 --- a/unison-src/tests/a-tale-of-two-optionals.u +++ b/unison-src/tests/a-tale-of-two-optionals.u @@ -1,4 +1,4 @@ -type Optional a = None | Some a +structural type Optional a = None | Some a Optional.isEmpty : Optional a -> Boolean Optional.isEmpty = cases diff --git a/unison-src/tests/ability-inference-fail.uu b/unison-src/tests/ability-inference-fail.uu index e0dfbf2d7f..d09a8daddb 100644 --- a/unison-src/tests/ability-inference-fail.uu +++ b/unison-src/tests/ability-inference-fail.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream a = Stream ('{Emit a} ()) +structural type Stream a = Stream ('{Emit a} ()) use Stream Stream use Optional None Some diff --git a/unison-src/tests/ability-keyword.u b/unison-src/tests/ability-keyword.u index afe11e7a94..f0c4ad8a01 100644 --- a/unison-src/tests/ability-keyword.u +++ b/unison-src/tests/ability-keyword.u @@ -1,7 +1,6 @@ - -ability Foo where +structural ability Foo where foo : {Foo} Text x = 'let y = Foo.foo - () + () \ No newline at end of file diff --git a/unison-src/tests/abort.u b/unison-src/tests/abort.u index f5649ac457..a6e9fd8d2e 100644 --- a/unison-src/tests/abort.u +++ b/unison-src/tests/abort.u @@ -1,5 +1,5 @@ --Abort -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a eff : forall a b . (a -> b) -> b -> Request Abort a -> b eff f z = cases diff --git a/unison-src/tests/ask-inferred.u b/unison-src/tests/ask-inferred.u index 266eb12e2c..387ab27db9 100644 --- a/unison-src/tests/ask-inferred.u +++ b/unison-src/tests/ask-inferred.u @@ -1,14 +1,14 @@ --Ask inferred -ability Ask a where +structural ability Ask a where ask : {Ask a} a -ability AskU where +structural ability AskU where ask : {AskU} Nat use Nat + -ability AskT where +structural ability AskT where ask : {AskT} Text x = '(Ask.ask + 1) diff --git a/unison-src/tests/cce.u b/unison-src/tests/cce.u index f7bb084729..de53c56965 100644 --- a/unison-src/tests/cce.u +++ b/unison-src/tests/cce.u @@ -1,9 +1,9 @@ use Universal < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -16,7 +16,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r @@ -51,7 +51,7 @@ List.map f as = Some a -> go f (acc `snoc` f a) as (i + 1) go f [] as 0 -type Monoid a = Monoid (a -> a -> a) a +structural type Monoid a = Monoid (a -> a -> a) a Monoid.zero = cases Monoid.Monoid op z -> z Monoid.op = cases Monoid.Monoid op z -> op diff --git a/unison-src/tests/console.u b/unison-src/tests/console.u index 881c2ed157..a8f0792274 100644 --- a/unison-src/tests/console.u +++ b/unison-src/tests/console.u @@ -1,8 +1,8 @@ -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/console1.u b/unison-src/tests/console1.u index c29d7b7ebf..71fc616d03 100644 --- a/unison-src/tests/console1.u +++ b/unison-src/tests/console1.u @@ -1,11 +1,11 @@ -- This confusingly gives an error that -- it doesn't know what `Console.simulate` is. -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/data-references-builtins.u b/unison-src/tests/data-references-builtins.u index 099ef4e284..80d6ea7dc1 100644 --- a/unison-src/tests/data-references-builtins.u +++ b/unison-src/tests/data-references-builtins.u @@ -1,4 +1,4 @@ --data references builtins -type StringOrInt = S Text | I Nat +structural type StringOrInt = S Text | I Nat > [StringOrInt.S "YO", StringOrInt.I 1] diff --git a/unison-src/tests/delay.u b/unison-src/tests/delay.u index 0935bbabb3..f40e9ed99e 100644 --- a/unison-src/tests/delay.u +++ b/unison-src/tests/delay.u @@ -1,5 +1,5 @@ -type Foo a = Foo a +structural type Foo a = Foo a (+) = (Nat.+) diff --git a/unison-src/tests/delay_parse.u b/unison-src/tests/delay_parse.u index 525f62eaa4..cf7b6e5699 100644 --- a/unison-src/tests/delay_parse.u +++ b/unison-src/tests/delay_parse.u @@ -1,4 +1,4 @@ -ability T where +structural ability T where foo : {T} () -- parses fine diff --git a/unison-src/tests/effect-instantiation.u b/unison-src/tests/effect-instantiation.u index 5ec6e1679b..6ef57c7cf8 100644 --- a/unison-src/tests/effect-instantiation.u +++ b/unison-src/tests/effect-instantiation.u @@ -2,7 +2,7 @@ blah : a -> a -> a blah a a2 = a2 -ability Foo where +structural ability Foo where foo : {Foo} Text -- previously this didn't work as first argument was pure diff --git a/unison-src/tests/effect-instantiation2.u b/unison-src/tests/effect-instantiation2.u index 6a12abb9ab..a47aea5aa5 100644 --- a/unison-src/tests/effect-instantiation2.u +++ b/unison-src/tests/effect-instantiation2.u @@ -2,7 +2,7 @@ woot : a -> a -> a woot a a2 = a -ability Hi where +structural ability Hi where hi : Float ->{Hi} Int > woot Float.floor Hi.hi diff --git a/unison-src/tests/effect1.u b/unison-src/tests/effect1.u index 81c772401b..aa0c2135d9 100644 --- a/unison-src/tests/effect1.u +++ b/unison-src/tests/effect1.u @@ -4,5 +4,5 @@ eff f z = cases { Abort.Abort _ -> k } -> z { a } -> f a -ability Abort where +structural ability Abort where Abort : forall a . () -> {Abort} a diff --git a/unison-src/tests/fix1185.u b/unison-src/tests/fix1185.u index a897cc17f1..0cea2dc591 100644 --- a/unison-src/tests/fix1185.u +++ b/unison-src/tests/fix1185.u @@ -8,7 +8,7 @@ -- This file won't typecheck unless the definitions get -- the correct inferred types. -ability Zonk where +structural ability Zonk where zonk : Nat -- should be inferred as: diff --git a/unison-src/tests/fix1695.u b/unison-src/tests/fix1695.u index a605acf2e4..91fdb5762d 100644 --- a/unison-src/tests/fix1695.u +++ b/unison-src/tests/fix1695.u @@ -1,5 +1,5 @@ -ability G a where +structural ability G a where get : a f x y = diff --git a/unison-src/tests/fix528.u b/unison-src/tests/fix528.u index c0dff14ec0..b93591ff17 100644 --- a/unison-src/tests/fix528.u +++ b/unison-src/tests/fix528.u @@ -4,7 +4,7 @@ a |> f = f a ex1 = "bob" |> (Text.++) "hi, " -type Woot = Woot Text Int Nat +structural type Woot = Woot Text Int Nat ex2 = match 0 |> Woot "Zonk" +10 with Woot.Woot _ i _ -> i diff --git a/unison-src/tests/fix739.u b/unison-src/tests/fix739.u index 28d36405c4..43d914f444 100644 --- a/unison-src/tests/fix739.u +++ b/unison-src/tests/fix739.u @@ -1,4 +1,4 @@ -type MonoidRec a = { +structural type MonoidRec a = { combine : a -> a -> a, empty : a } diff --git a/unison-src/tests/force.u b/unison-src/tests/force.u index b4e1d2bdf8..2c33b014d5 100644 --- a/unison-src/tests/force.u +++ b/unison-src/tests/force.u @@ -1,4 +1,4 @@ -ability Woot where woot : {Woot} Text +structural ability Woot where woot : {Woot} Text force : '{e} a ->{e} a force a = !a diff --git a/unison-src/tests/guard-boolean-operators.u b/unison-src/tests/guard-boolean-operators.u index a5da96a178..fc04e5468e 100644 --- a/unison-src/tests/guard-boolean-operators.u +++ b/unison-src/tests/guard-boolean-operators.u @@ -1,4 +1,4 @@ -type Foo = Foo Boolean Boolean +structural type Foo = Foo Boolean Boolean f : Foo -> Boolean f = cases diff --git a/unison-src/tests/handler-stacking.u b/unison-src/tests/handler-stacking.u index 97d4322ee1..46c2d5c456 100644 --- a/unison-src/tests/handler-stacking.u +++ b/unison-src/tests/handler-stacking.u @@ -15,11 +15,11 @@ replicate n x = !x replicate (n `drop` 1) x -ability State a where +structural ability State a where get : {State a} a put : a -> {State a} () -ability Writer w where +structural ability Writer w where tell : w -> {Writer w} () stateHandler : s -> Request {State s} a -> (s, a) diff --git a/unison-src/tests/hang.u b/unison-src/tests/hang.u index 75702f8ef5..49cd4210af 100644 --- a/unison-src/tests/hang.u +++ b/unison-src/tests/hang.u @@ -1,10 +1,10 @@ use Universal == < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -17,7 +17,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r diff --git a/unison-src/tests/id.u b/unison-src/tests/id.u index 7d0bd3d4d2..39b03ed544 100644 --- a/unison-src/tests/id.u +++ b/unison-src/tests/id.u @@ -1,5 +1,4 @@ id : a -> a id x = x -> id - +> id \ No newline at end of file diff --git a/unison-src/tests/if.u b/unison-src/tests/if.u index e3af85295c..cc1e77684a 100644 --- a/unison-src/tests/if.u +++ b/unison-src/tests/if.u @@ -1,2 +1,2 @@ foo = if true then true else false -> foo +> foo \ No newline at end of file diff --git a/unison-src/tests/io-state2.u b/unison-src/tests/io-state2.u index e5ac00d21c..48f825cb86 100644 --- a/unison-src/tests/io-state2.u +++ b/unison-src/tests/io-state2.u @@ -1,5 +1,5 @@ --IO/State2 ability -ability IO where +structural ability IO where launchMissiles : {IO} () foo : Int -> {IO} Int @@ -12,10 +12,10 @@ foo unit = +42 +43 -type Optional a = +structural type Optional a = Some a | None -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . {State se} se diff --git a/unison-src/tests/io-state3.u b/unison-src/tests/io-state3.u index ca05a59cd0..9167be8a05 100644 --- a/unison-src/tests/io-state3.u +++ b/unison-src/tests/io-state3.u @@ -1,5 +1,5 @@ --IO3 ability -ability IO where +structural ability IO where launchMissiles : () -> {IO} () -- binding IS guarded, so its body can access whatever abilities -- are declared by the type of the binding diff --git a/unison-src/tests/map-traverse.u b/unison-src/tests/map-traverse.u index 980927ca77..95b884e847 100644 --- a/unison-src/tests/map-traverse.u +++ b/unison-src/tests/map-traverse.u @@ -1,11 +1,11 @@ --map/traverse -ability Noop where +structural ability Noop where noop : ∀ a . a -> {Noop} a -ability Noop2 where +structural ability Noop2 where noop2 : ∀ a . a -> a -> {Noop2} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : ∀ a b e . (a -> {e} b) -> List a -> {e} (List b) map f = cases diff --git a/unison-src/tests/map-traverse2.u b/unison-src/tests/map-traverse2.u index 61ee14c168..aba52594af 100644 --- a/unison-src/tests/map-traverse2.u +++ b/unison-src/tests/map-traverse2.u @@ -1,11 +1,11 @@ --map/traverse -ability Noop where +structural ability Noop where noop : a -> {Noop} a -ability Noop2 where +structural ability Noop2 where noop2 : a -> a -> {Noop2} a -type List a = Nil | Cons a (List a) +structural type List a = Nil | Cons a (List a) map : (a -> b) -> List a -> List b map f = cases diff --git a/unison-src/tests/methodical/abilities.u b/unison-src/tests/methodical/abilities.u index 339fb25577..0192082bd7 100644 --- a/unison-src/tests/methodical/abilities.u +++ b/unison-src/tests/methodical/abilities.u @@ -1,7 +1,7 @@ -- ABILITIES -ability A where +structural ability A where woot : {A} Nat unA = cases @@ -15,7 +15,7 @@ a1 = handle x with unA -ability B where +structural ability B where zing : {B} Int abh = cases @@ -43,7 +43,7 @@ ab2 = with nh with abh -ability C where +structural ability C where n : Nat i : Int diff --git a/unison-src/tests/methodical/apply-constructor.u b/unison-src/tests/methodical/apply-constructor.u index a652f0cba4..9b3e98aa1f 100644 --- a/unison-src/tests/methodical/apply-constructor.u +++ b/unison-src/tests/methodical/apply-constructor.u @@ -2,7 +2,7 @@ -- Now check exact and underapply cases for constructors -- (overapply of a constructor is always a type error) -type Woot = Woot Nat Nat Nat Nat +structural type Woot = Woot Nat Nat Nat Nat toSeq : Woot -> [Nat] toSeq = cases diff --git a/unison-src/tests/methodical/cycle-minimize.u b/unison-src/tests/methodical/cycle-minimize.u index fc6356e719..837bb58ca2 100644 --- a/unison-src/tests/methodical/cycle-minimize.u +++ b/unison-src/tests/methodical/cycle-minimize.u @@ -1,5 +1,5 @@ -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> () -- should typecheck fine, as the `launchMissiles "saturn"` diff --git a/unison-src/tests/methodical/overapply-ability.u b/unison-src/tests/methodical/overapply-ability.u index 539871c4f4..bb6dfab74d 100644 --- a/unison-src/tests/methodical/overapply-ability.u +++ b/unison-src/tests/methodical/overapply-ability.u @@ -2,7 +2,7 @@ -- A corner case in the runtime is when a function is being overapplied and -- the exactly applied function requests an ability (and returns a new function) -ability Zing where +structural ability Zing where zing : Nat -> {Zing} (Nat -> Nat) zing2 : Nat -> Nat ->{Zing} (Nat -> Nat -> [Nat]) diff --git a/unison-src/tests/multiple-effects.u b/unison-src/tests/multiple-effects.u index e01edb87b6..12c636a523 100644 --- a/unison-src/tests/multiple-effects.u +++ b/unison-src/tests/multiple-effects.u @@ -1,8 +1,8 @@ -ability State s where +structural ability State s where get : {State s} s set : s -> {State s} () -ability Console where +structural ability Console where read : {Console} (Optional Text) write : Text -> {Console} () diff --git a/unison-src/tests/pattern-matching.u b/unison-src/tests/pattern-matching.u index 866fbb887d..b1e2b3c7e7 100644 --- a/unison-src/tests/pattern-matching.u +++ b/unison-src/tests/pattern-matching.u @@ -1,8 +1,8 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c -type List a = Nil | Cons a (List a) +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c +structural type List a = Nil | Cons a (List a) use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/tests/pattern-matching2.u b/unison-src/tests/pattern-matching2.u index 7bd1bf069b..4f6dd8c402 100644 --- a/unison-src/tests/pattern-matching2.u +++ b/unison-src/tests/pattern-matching2.u @@ -1,7 +1,7 @@ -type Foo0 = Foo0 -type Foo1 a = Foo1 a -type Foo2 a b = Foo2 a b -type Foo3 a b c = Foo3 a b c +structural type Foo0 = Foo0 +structural type Foo1 a = Foo1 a +structural type Foo2 a b = Foo2 a b +structural type Foo3 a b c = Foo3 a b c use Foo0 Foo0 use Foo1 Foo1 diff --git a/unison-src/tests/pattern-typing-bug.u b/unison-src/tests/pattern-typing-bug.u index 5ac1d44814..d9bbdf185a 100644 --- a/unison-src/tests/pattern-typing-bug.u +++ b/unison-src/tests/pattern-typing-bug.u @@ -1,4 +1,4 @@ -type Value = String Text +structural type Value = String Text | Bool Boolean f : Value -> Nat diff --git a/unison-src/tests/r1.u b/unison-src/tests/r1.u index 855e2d2bf1..3bc960ab01 100644 --- a/unison-src/tests/r1.u +++ b/unison-src/tests/r1.u @@ -1,5 +1,5 @@ --r1 -type Optional a = None | Some a +structural type Optional a = None | Some a r1 : Nat r1 = match Optional.Some 3 with x -> 1 diff --git a/unison-src/tests/r2.u b/unison-src/tests/r2.u index a3b925bc1e..8218decb76 100644 --- a/unison-src/tests/r2.u +++ b/unison-src/tests/r2.u @@ -1,4 +1,4 @@ -type Optional a = None | Some a +structural type Optional a = None | Some a r2 : Nat r2 = match Optional.Some true with Optional.Some true -> 1 diff --git a/unison-src/tests/rainbow.u b/unison-src/tests/rainbow.u index 378118d1d5..30befdb068 100644 --- a/unison-src/tests/rainbow.u +++ b/unison-src/tests/rainbow.u @@ -21,10 +21,10 @@ rainbow x = d = (Ask.ask : Int) +42 -ability Ask a where +structural ability Ask a where ask : {Ask a} a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b unique ability Zang where zang : {Zang} Nat diff --git a/unison-src/tests/records.u b/unison-src/tests/records.u index 2528896a65..907e184743 100644 --- a/unison-src/tests/records.u +++ b/unison-src/tests/records.u @@ -1,9 +1,9 @@ -type Point x y = { x : x, y : y } +structural type Point x y = { x : x, y : y } -type Point2 = { point2 : Nat, f : Nat } +structural type Point2 = { point2 : Nat, f : Nat } -type Monoid a = { zero : a, plus : a -> a -> a } +structural type Monoid a = { zero : a, plus : a -> a -> a } > Point.x.set 10 (Point 0 0) > Point.x (Point 10 0) diff --git a/unison-src/tests/sequence-literal-argument-parsing.u b/unison-src/tests/sequence-literal-argument-parsing.u index 8005a67566..d6d495bcaf 100644 --- a/unison-src/tests/sequence-literal-argument-parsing.u +++ b/unison-src/tests/sequence-literal-argument-parsing.u @@ -1,4 +1,4 @@ -type X a = X [a] +structural type X a = X [a] f : X a -> a f = cases diff --git a/unison-src/tests/soe.u b/unison-src/tests/soe.u index dd3b2c62b8..0ce0392ee1 100644 --- a/unison-src/tests/soe.u +++ b/unison-src/tests/soe.u @@ -1,10 +1,10 @@ use Universal == < -type Future a = Future ('{Remote} a) +structural type Future a = Future ('{Remote} a) -- A simple distributed computation ability -ability Remote where +structural ability Remote where -- Spawn a new node spawn : {Remote} Node @@ -17,7 +17,7 @@ ability Remote where -- await the result of the computation fork : '{Remote} a ->{Remote} Future a -type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair +structural type Node = Node Nat -- more realistic would be perhaps a (Hostname, PublicKey) pair force : Future a ->{Remote} a force = cases Future.Future r -> !r @@ -50,7 +50,7 @@ List.map f as = Some a -> go f (acc `snoc` f a) as (i + 1) go f [] as 0 -type Monoid a = Monoid (a -> a -> a) a +structural type Monoid a = Monoid (a -> a -> a) a Monoid.zero = cases Monoid.Monoid op z -> z Monoid.op = cases Monoid.Monoid op z -> op diff --git a/unison-src/tests/spurious-ability-fail-underapply.u b/unison-src/tests/spurious-ability-fail-underapply.u index 64cec3c053..1d14530288 100644 --- a/unison-src/tests/spurious-ability-fail-underapply.u +++ b/unison-src/tests/spurious-ability-fail-underapply.u @@ -1,4 +1,4 @@ -ability Woot where +structural ability Woot where woot : {Woot} Nat wha : ((a ->{Woot} a) -> a ->{Woot} a) -> Nat diff --git a/unison-src/tests/state1.u b/unison-src/tests/state1.u index 61b0e2cb98..4a529b303b 100644 --- a/unison-src/tests/state1.u +++ b/unison-src/tests/state1.u @@ -1,5 +1,5 @@ --State1 ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se diff --git a/unison-src/tests/state1a.u b/unison-src/tests/state1a.u index 471170b869..ed588573c7 100644 --- a/unison-src/tests/state1a.u +++ b/unison-src/tests/state1a.u @@ -1,5 +1,5 @@ --State1a ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . {State se} se id : Int -> Int diff --git a/unison-src/tests/state2.u b/unison-src/tests/state2.u index 62337b1074..acf525f9b4 100644 --- a/unison-src/tests/state2.u +++ b/unison-src/tests/state2.u @@ -1,5 +1,5 @@ --State2 ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se state : ∀ s a . s -> Request (State s) a -> (s, a) diff --git a/unison-src/tests/state2a-min.u b/unison-src/tests/state2a-min.u index 63a632a703..c62a8c08c3 100644 --- a/unison-src/tests/state2a-min.u +++ b/unison-src/tests/state2a-min.u @@ -1,5 +1,5 @@ --State2 ability -ability State s where +structural ability State s where put : s -> {State s} () state : s -> Request (State s) a -> a diff --git a/unison-src/tests/state2a.u b/unison-src/tests/state2a.u index c2dcc58a00..cd98bbad2f 100644 --- a/unison-src/tests/state2a.u +++ b/unison-src/tests/state2a.u @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state2a.uu b/unison-src/tests/state2a.uu index 82a2306eb9..8b0dc5587a 100644 --- a/unison-src/tests/state2a.uu +++ b/unison-src/tests/state2a.uu @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state2b-min.u b/unison-src/tests/state2b-min.u index 257ca9e3e3..44c971cb80 100644 --- a/unison-src/tests/state2b-min.u +++ b/unison-src/tests/state2b-min.u @@ -1,5 +1,5 @@ --State2 ability -ability State s where +structural ability State s where put : s -> {State s} () state : s -> Request (State s) a -> s diff --git a/unison-src/tests/state2b.u b/unison-src/tests/state2b.u index b036ed0283..561ce71095 100644 --- a/unison-src/tests/state2b.u +++ b/unison-src/tests/state2b.u @@ -1,8 +1,8 @@ --State2 ability -type Optional a = None | Some a +structural type Optional a = None | Some a -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state3.u b/unison-src/tests/state3.u index cc15016819..bebb7d1637 100644 --- a/unison-src/tests/state3.u +++ b/unison-src/tests/state3.u @@ -1,5 +1,5 @@ --State3 ability -ability State se2 where +structural ability State se2 where put : ∀ se . se -> {State se} () get : ∀ se . () -> {State se} se diff --git a/unison-src/tests/state4.u b/unison-src/tests/state4.u index 3db4bd9c40..3ed0e7aba2 100644 --- a/unison-src/tests/state4.u +++ b/unison-src/tests/state4.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/state4a.u b/unison-src/tests/state4a.u index 04544e9451..8455432d4a 100644 --- a/unison-src/tests/state4a.u +++ b/unison-src/tests/state4a.u @@ -1,4 +1,4 @@ -ability State s where +structural ability State s where put : s -> {State s} () get : {State s} s diff --git a/unison-src/tests/stream.u b/unison-src/tests/stream.u index f790e97df7..bd170a7042 100644 --- a/unison-src/tests/stream.u +++ b/unison-src/tests/stream.u @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some diff --git a/unison-src/tests/stream2.uu b/unison-src/tests/stream2.uu index fd2862d479..8daa0111db 100644 --- a/unison-src/tests/stream2.uu +++ b/unison-src/tests/stream2.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some diff --git a/unison-src/tests/stream3.uu b/unison-src/tests/stream3.uu index 3e6a2d5e8d..cbb3d1c6e1 100644 --- a/unison-src/tests/stream3.uu +++ b/unison-src/tests/stream3.uu @@ -1,7 +1,7 @@ -ability Emit a where +structural ability Emit a where emit : a ->{Emit a} () -type Stream e a r = Stream ('{e, Emit a} r) +structural type Stream e a r = Stream ('{e, Emit a} r) use Stream Stream use Optional None Some @@ -50,7 +50,7 @@ namespace Stream where run : Stream e a r ->{e, Emit a} r run = cases Stream c -> !c -ability Abort where +structural ability Abort where abort : {Abort} a --- diff --git a/unison-src/tests/tictactoe.u b/unison-src/tests/tictactoe.u index e3dde4d4ba..390b69f33a 100644 --- a/unison-src/tests/tictactoe.u +++ b/unison-src/tests/tictactoe.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe0-array-oob1.u b/unison-src/tests/tictactoe0-array-oob1.u index 22989cd6e6..cbabf6b46e 100644 --- a/unison-src/tests/tictactoe0-array-oob1.u +++ b/unison-src/tests/tictactoe0-array-oob1.u @@ -1,6 +1,6 @@ -- board piece -type Board = Board Nat Nat Nat +structural type Board = Board Nat Nat Nat use Board Board diff --git a/unison-src/tests/tictactoe0-npe.u b/unison-src/tests/tictactoe0-npe.u index d1845df897..9edc4c58d6 100644 --- a/unison-src/tests/tictactoe0-npe.u +++ b/unison-src/tests/tictactoe0-npe.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe0.u b/unison-src/tests/tictactoe0.u index a6e0ff7a52..d0628f7205 100644 --- a/unison-src/tests/tictactoe0.u +++ b/unison-src/tests/tictactoe0.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/tictactoe2.u b/unison-src/tests/tictactoe2.u index cf02bcc44c..9ebaf3b307 100644 --- a/unison-src/tests/tictactoe2.u +++ b/unison-src/tests/tictactoe2.u @@ -1,7 +1,7 @@ -- board piece -type P = X | O | E +structural type P = X | O | E -type Board = Board P P P P P P P P P +structural type Board = Board P P P P P P P P P use Board Board use P O X E diff --git a/unison-src/tests/type-application.u b/unison-src/tests/type-application.u index ae54823ad7..87b673809d 100644 --- a/unison-src/tests/type-application.u +++ b/unison-src/tests/type-application.u @@ -1,8 +1,8 @@ -ability Foo where +structural ability Foo where foo : {Foo} Nat -type Wrap a = Wrap Nat +structural type Wrap a = Wrap Nat blah : Wrap {Foo} -> Nat blah = cases diff --git a/unison-src/tests/ungeneralize-bug.uu b/unison-src/tests/ungeneralize-bug.uu index 5a5448ed17..f3fc3403c2 100644 --- a/unison-src/tests/ungeneralize-bug.uu +++ b/unison-src/tests/ungeneralize-bug.uu @@ -2,7 +2,7 @@ use Foo Foo use Optional Some None -type Foo a b = Foo a (Optional b) +structural type Foo a b = Foo a (Optional b) foo : Foo a b -> (b -> c) -> Foo a c foo x f = match x with diff --git a/unison-src/tests/void.u b/unison-src/tests/void.u index a4e646ad32..701265f629 100644 --- a/unison-src/tests/void.u +++ b/unison-src/tests/void.u @@ -1,3 +1,3 @@ -type Void = +structural type Void = > 3 diff --git a/unison-src/transcripts-using-base/base.u b/unison-src/transcripts-using-base/base.u index 1d49c6dd8c..0b32ce5059 100644 --- a/unison-src/transcripts-using-base/base.u +++ b/unison-src/transcripts-using-base/base.u @@ -7,7 +7,7 @@ compose3 f g = a -> b -> c -> f (g a b c) id a = a -ability Exception where +structural ability Exception where raise: io2.Failure -> anything Exception.reraise : Either Failure a ->{Exception} a @@ -23,7 +23,7 @@ Exception.toEither.handler = cases Exception.toEither : '{ε, Exception} a -> {ε} Either Failure a Exception.toEither a = handle !a with Exception.toEither.handler -ability Throw e where +structural ability Throw e where throw : e -> a List.all : (a ->{ε} Boolean) -> [a] ->{ε} Boolean @@ -66,7 +66,7 @@ isNone = cases None -> true -ability Stream a where +structural ability Stream a where emit: a -> () Stream.toList.handler : Request {Stream a} r -> [a] @@ -97,7 +97,7 @@ Stream.collect s = -- An ability that facilitates creating temoporary directories that can be -- automatically cleaned up -ability TempDirs where +structural ability TempDirs where newTempDir: Text -> Text removeDir: Text -> () diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 7933a428cd..94db31d190 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -36,7 +36,7 @@ identical err x y = then () else throw ("mismatch" ++ err) -type Three a b c = zero a | one b | two c +structural type Three a b c = zero a | one b | two c showThree : Three Nat Nat Nat -> Text showThree = cases @@ -89,7 +89,7 @@ identicality t x ``` ```unison -ability Zap where +structural ability Zap where zap : Three Nat Nat Nat h : Three Nat Nat Nat -> Nat -> Nat diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index a2b7856d5e..eb8d902d4a 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -31,7 +31,7 @@ identical err x y = then () else throw ("mismatch" ++ err) -type Three a b c = zero a | one b | two c +structural type Three a b c = zero a | one b | two c showThree : Three Nat Nat Nat -> Text showThree = cases @@ -87,7 +87,7 @@ identicality t x ⍟ These new definitions are ok to `add`: - type Three a b c + structural type Three a b c concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -114,7 +114,7 @@ identicality t x ⍟ I've added these definitions: - type Three a b c + structural type Three a b c concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -137,7 +137,7 @@ identicality t x ``` ```unison -ability Zap where +structural ability Zap where zap : Three Nat Nat Nat h : Three Nat Nat Nat -> Nat -> Nat @@ -212,7 +212,7 @@ badLoad _ = ⍟ These new definitions are ok to `add`: - ability Zap + structural ability Zap badLoad : '{IO} [Result] f : Nat ->{Zap} Nat fDeps : [Link.Term] @@ -233,7 +233,7 @@ to actual show that the serialization works. ⍟ I've added these definitions: - ability Zap + structural ability Zap badLoad : '{IO} [Result] f : Nat ->{Zap} Nat fDeps : [Link.Term] diff --git a/unison-src/transcripts-using-base/doc.output.md b/unison-src/transcripts-using-base/doc.output.md index 38321c8895..badb23bbac 100644 --- a/unison-src/transcripts-using-base/doc.output.md +++ b/unison-src/transcripts-using-base/doc.output.md @@ -335,7 +335,7 @@ and the rendered output using `display`: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -343,7 +343,7 @@ and the rendered output using `display`: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -637,7 +637,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -645,7 +645,7 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * diff --git a/unison-src/transcripts-using-base/fix2027.md b/unison-src/transcripts-using-base/fix2027.md index fc0fc9f7b8..23e9498cab 100644 --- a/unison-src/transcripts-using-base/fix2027.md +++ b/unison-src/transcripts-using-base/fix2027.md @@ -5,13 +5,13 @@ ``` ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x reraise = cases Left e -> raise e Right a -> a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b putBytes h bs = reraise (putBytes.impl h bs) diff --git a/unison-src/transcripts-using-base/fix2027.output.md b/unison-src/transcripts-using-base/fix2027.output.md index 59e3783331..de62d3c43b 100644 --- a/unison-src/transcripts-using-base/fix2027.output.md +++ b/unison-src/transcripts-using-base/fix2027.output.md @@ -1,13 +1,13 @@ ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x reraise = cases Left e -> raise e Right a -> a -type Either a b = Left a | Right b +structural type Either a b = Left a | Right b putBytes h bs = reraise (putBytes.impl h bs) @@ -52,34 +52,29 @@ myServer = unsafeRun! '(hello "127.0.0.1" "0") do an `add` or `update`, here's how your codebase would change: - ⊡ Previously added definitions will be ignored: Exception - Exception.raise - ⍟ These new definitions are ok to `add`: - type Either a b + structural type Either a b (also named builtin.Either) + structural ability Exception + (also named builtin.Exception) Exception.unsafeRun! : '{g, Exception} a -> '{g} a bugFail : Failure -> r + closeSocket : Socket ->{IO, Exception} () hello : Text -> Text ->{IO, Exception} () myServer : '{IO} () + putBytes : Handle + -> Bytes + ->{IO, Exception} () putText : Handle -> Text ->{IO, Exception} () reraise : Either Failure b ->{Exception} b - (also named Exception.reraise) + serverSocket : Optional Text + -> Text + ->{IO, Exception} Socket socketSend : Socket -> Bytes ->{IO, Exception} () toException : Either Failure a ->{Exception} a - (also named Exception.reraise) - - ⍟ These names already exist. You can `update` them to your - new definition: - - closeSocket : Socket ->{IO, Exception} () - putBytes : Handle -> Bytes ->{IO, Exception} () - serverSocket : Optional Text - -> Text - ->{IO, Exception} Socket ``` ```ucm diff --git a/unison-src/transcripts-using-base/fix2158-1.md b/unison-src/transcripts-using-base/fix2158-1.md index c80faa3f1f..16721569e5 100644 --- a/unison-src/transcripts-using-base/fix2158-1.md +++ b/unison-src/transcripts-using-base/fix2158-1.md @@ -1,7 +1,7 @@ This transcript tests an ability check failure regression. ```unison -ability Async t g where +structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a diff --git a/unison-src/transcripts-using-base/fix2158-1.output.md b/unison-src/transcripts-using-base/fix2158-1.output.md index f9419e4a42..645cfe8013 100644 --- a/unison-src/transcripts-using-base/fix2158-1.output.md +++ b/unison-src/transcripts-using-base/fix2158-1.output.md @@ -1,7 +1,7 @@ This transcript tests an ability check failure regression. ```unison -ability Async t g where +structural ability Async t g where fork : '{Async t g, g} a -> t a await : t a -> a @@ -19,7 +19,7 @@ Async.parMap f as = ⍟ These new definitions are ok to `add`: - ability Async t g + structural ability Async t g Async.parMap : (a ->{g, Async t g} b) -> [a] ->{Async t g} [b] diff --git a/unison-src/transcripts-using-base/fix2297.output.md b/unison-src/transcripts-using-base/fix2297.output.md index a2a8f85a85..fb2aa368d6 100644 --- a/unison-src/transcripts-using-base/fix2297.output.md +++ b/unison-src/transcripts-using-base/fix2297.output.md @@ -27,9 +27,13 @@ wat = handleTrivial testAction -- Somehow this completely forgets about Excepti ```ucm - The expression in red needs the {Exception} ability, but this location does not have access to any abilities. + I expected to see `structural` or `unique` at the start of + this line: - 19 | wat = handleTrivial testAction -- Somehow this completely forgets about Exception and IO + 1 | ability Trivial where + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types ``` diff --git a/unison-src/transcripts/addupdatemessages.output.md b/unison-src/transcripts/addupdatemessages.output.md index 6dc3cfb675..ce3488b205 100644 --- a/unison-src/transcripts/addupdatemessages.output.md +++ b/unison-src/transcripts/addupdatemessages.output.md @@ -6,8 +6,8 @@ Let's set up some definitions to start: x = 1 y = 2 -structural type X = One Nat -structural type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm @@ -44,7 +44,7 @@ Let's add an alias for `1` and `One`: ```unison z = 1 -structural type Z = One Nat +structural type Z = One Nat ``` ```ucm @@ -79,7 +79,7 @@ Let's update something that has an alias (to a value that doesn't have a name al ```unison x = 3 -structural type X = Three Nat Nat Nat +structural type X = Three Nat Nat Nat ``` ```ucm @@ -118,7 +118,7 @@ Update it to something that already exists with a different name: ```unison x = 2 -structural type X = Two Nat Nat +structural type X = Two Nat Nat ``` ```ucm diff --git a/unison-src/transcripts/blocks.md b/unison-src/transcripts/blocks.md index c7f4277090..f767391012 100644 --- a/unison-src/transcripts/blocks.md +++ b/unison-src/transcripts/blocks.md @@ -125,7 +125,7 @@ Just don't try to run it as it's an infinite loop! The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: ```unison:error -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -139,7 +139,7 @@ ex n = For instance, this works fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -153,7 +153,7 @@ ex n = For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -166,7 +166,7 @@ ex n = This is actually parsed as if you moved `zap` after the cycle it find itself a part of: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = diff --git a/unison-src/transcripts/blocks.output.md b/unison-src/transcripts/blocks.output.md index 3c82472504..28628efede 100644 --- a/unison-src/transcripts/blocks.output.md +++ b/unison-src/transcripts/blocks.output.md @@ -242,7 +242,7 @@ Just don't try to run it as it's an infinite loop! The reason is it's unclear what the order should be of any requests that are made. It can also be viewed of a special case of the restriction that elements of a cycle must all be guarded. Here's an example: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -264,7 +264,7 @@ ex n = For instance, this works fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -281,7 +281,7 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} Nat ``` @@ -290,7 +290,7 @@ ex n = For instance, `zap` here isn't considered part of the cycle (it doesn't reference `ping` or `pong`), so this typechecks fine: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -308,14 +308,14 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} r ``` This is actually parsed as if you moved `zap` after the cycle it find itself a part of: ```unison -ability SpaceAttack where +structural ability SpaceAttack where launchMissiles : Text -> Nat ex n = @@ -333,7 +333,7 @@ ex n = ⍟ These new definitions are ok to `add`: - ability SpaceAttack + structural ability SpaceAttack ex : n ->{SpaceAttack} r ``` diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md index b6ec787738..8d2aacaabb 100644 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ b/unison-src/transcripts/bug-strange-closure.output.md @@ -88,7 +88,7 @@ We can display the guide before and after adding it to the codebase: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -96,7 +96,7 @@ We can display the guide before and after adding it to the codebase: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -289,7 +289,7 @@ We can display the guide before and after adding it to the codebase: Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -297,7 +297,7 @@ We can display the guide before and after adding it to the codebase: Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -496,7 +496,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -504,7 +504,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -690,7 +690,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Unison definitions can be included in docs. For instance: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * @@ -698,7 +698,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) Some rendering targets also support folded source: - type Optional a = None | Some a + structural type Optional a = None | Some a sqr x = use Nat * diff --git a/unison-src/transcripts/command-replace.output.md b/unison-src/transcripts/command-replace.output.md index 8957f570e3..84f905e1e8 100644 --- a/unison-src/transcripts/command-replace.output.md +++ b/unison-src/transcripts/command-replace.output.md @@ -6,8 +6,8 @@ Let's set up some definitions to start: x = 1 y = 2 -type X = One Nat -type Y = Two Nat Nat +structural type X = One Nat +structural type Y = Two Nat Nat ``` ```ucm @@ -18,8 +18,8 @@ type Y = Two Nat Nat ⍟ These new definitions are ok to `add`: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -31,8 +31,8 @@ type Y = Two Nat Nat ⍟ I've added these definitions: - type X - type Y + structural type X + structural type Y x : Nat y : Nat @@ -57,10 +57,10 @@ Test that replace works with types .scratch> find - 1. type X + 1. structural type X 2. x : Nat 3. X.One : Nat -> Nat -> X - 4. type Y + 4. structural type Y 5. y : Nat 6. Y.Two : Nat -> Nat -> X @@ -77,7 +77,7 @@ Test that replace works with types .scratch> view X - type X = One Nat Nat + structural type X = One Nat Nat ``` Try with a type/term mismatch diff --git a/unison-src/transcripts/diff.md b/unison-src/transcripts/diff.md index 5846af90c1..1f31db2a84 100644 --- a/unison-src/transcripts/diff.md +++ b/unison-src/transcripts/diff.md @@ -40,8 +40,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -type A a = A Nat -ability X a1 a2 where x : Nat +structural type A a = A Nat +structural ability X a1 a2 where x : Nat ``` ```ucm diff --git a/unison-src/transcripts/diff.output.md b/unison-src/transcripts/diff.output.md index cda20f1fcb..9cec95d7f2 100644 --- a/unison-src/transcripts/diff.output.md +++ b/unison-src/transcripts/diff.output.md @@ -105,8 +105,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -type A a = A Nat -ability X a1 a2 where x : Nat +structural type A a = A Nat +structural ability X a1 a2 where x : Nat ``` ```ucm @@ -116,8 +116,8 @@ ability X a1 a2 where x : Nat ⍟ I've added these definitions: - type A a - ability X a1 a2 + structural type A a + structural ability X a1 a2 b : Nat bdependent : Nat c : Nat @@ -155,8 +155,8 @@ Here's what we've done so far: Added definitions: - 1. type A a - 2. ability X a1 a2 + 1. structural type A a + 2. structural ability X a1 a2 3. A.A : Nat -> A a 4. X.x : {X a1 a2} Nat 5. b : Nat diff --git a/unison-src/transcripts/docs.output.md b/unison-src/transcripts/docs.output.md index f4d9d2adb0..a78489a956 100644 --- a/unison-src/transcripts/docs.output.md +++ b/unison-src/transcripts/docs.output.md @@ -14,7 +14,7 @@ Unison documentation is written in Unison. Documentation is a value of the follo | Evaluate Term ``` -You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of type `Doc` can be created via syntax like: +You can create these `Doc` values with ordinary code, or you can use the special syntax. A value of structural type `Doc` can be created via syntax like: ```unison use .builtin diff --git a/unison-src/transcripts/fix1731.md b/unison-src/transcripts/fix1731.md index 29fd0d5f0f..81adcd8de2 100644 --- a/unison-src/transcripts/fix1731.md +++ b/unison-src/transcripts/fix1731.md @@ -4,7 +4,7 @@ ``` ```unison:hide -ability CLI where +structural ability CLI where print : Text ->{CLI} () input : {CLI} Text ``` diff --git a/unison-src/transcripts/fix1731.output.md b/unison-src/transcripts/fix1731.output.md index 48fe35db69..3ed9b26b3a 100644 --- a/unison-src/transcripts/fix1731.output.md +++ b/unison-src/transcripts/fix1731.output.md @@ -1,6 +1,6 @@ ```unison -ability CLI where +structural ability CLI where print : Text ->{CLI} () input : {CLI} Text ``` diff --git a/unison-src/transcripts/fix2026.md b/unison-src/transcripts/fix2026.md index 56ddc81674..819a579e2f 100644 --- a/unison-src/transcripts/fix2026.md +++ b/unison-src/transcripts/fix2026.md @@ -3,7 +3,7 @@ ``` ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x ex = unsafeRun! '(printLine "hello world") diff --git a/unison-src/transcripts/fix2026.output.md b/unison-src/transcripts/fix2026.output.md index e28df2509d..b8b91f0955 100644 --- a/unison-src/transcripts/fix2026.output.md +++ b/unison-src/transcripts/fix2026.output.md @@ -1,5 +1,5 @@ ```unison -ability Exception where raise : Failure -> x +structural ability Exception where raise : Failure -> x ex = unsafeRun! '(printLine "hello world") @@ -43,7 +43,7 @@ Exception.unsafeRun! e _ = ⍟ These new definitions are ok to `add`: - ability Exception + structural ability Exception (also named builtin.Exception) Exception.unsafeRun! : '{g, Exception} a -> '{g} a compose2 : (c ->{𝕖1} d) diff --git a/unison-src/transcripts/fix2167.md b/unison-src/transcripts/fix2167.md index cb5a64f302..4e65ddb6f6 100644 --- a/unison-src/transcripts/fix2167.md +++ b/unison-src/transcripts/fix2167.md @@ -6,7 +6,7 @@ This is just a simple transcript to regression check an ability inference/checking issue. ```unison -ability R t where +structural ability R t where die : () -> x near.impl : Nat -> Either () [Nat] diff --git a/unison-src/transcripts/fix2167.output.md b/unison-src/transcripts/fix2167.output.md index 4a6f3de654..28826bdcf5 100644 --- a/unison-src/transcripts/fix2167.output.md +++ b/unison-src/transcripts/fix2167.output.md @@ -2,7 +2,7 @@ This is just a simple transcript to regression check an ability inference/checking issue. ```unison -ability R t where +structural ability R t where die : () -> x near.impl : Nat -> Either () [Nat] @@ -23,7 +23,7 @@ R.near1 region loc = match R.near 42 with ⍟ These new definitions are ok to `add`: - ability R t + structural ability R t R.near : Nat ->{R t} [Nat] R.near1 : region -> loc ->{R t} Nat diff --git a/unison-src/transcripts/fix2238.md b/unison-src/transcripts/fix2238.md index eaacb39b43..3562096397 100644 --- a/unison-src/transcripts/fix2238.md +++ b/unison-src/transcripts/fix2238.md @@ -6,7 +6,7 @@ This should not typecheck - the inline `@eval` expression uses abilities. ```unison:error -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ @eval{abort} }} ``` diff --git a/unison-src/transcripts/fix2238.output.md b/unison-src/transcripts/fix2238.output.md index 595118463b..a54cdd81b7 100644 --- a/unison-src/transcripts/fix2238.output.md +++ b/unison-src/transcripts/fix2238.output.md @@ -2,7 +2,7 @@ This should not typecheck - the inline `@eval` expression uses abilities. ```unison -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ @eval{abort} }} ``` diff --git a/unison-src/transcripts/fix2238.u b/unison-src/transcripts/fix2238.u index 01fcf7cc38..19e81357ee 100644 --- a/unison-src/transcripts/fix2238.u +++ b/unison-src/transcripts/fix2238.u @@ -1,5 +1,5 @@ -ability Abort where abort : x +structural ability Abort where abort : x ex = {{ diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md index 3f53636f61..21b13d2d98 100644 --- a/unison-src/transcripts/fix2254.output.md +++ b/unison-src/transcripts/fix2254.output.md @@ -8,7 +8,7 @@ unique type A a b c d | C c | D d -type NeedsA a b = NeedsA (A a b Nat Nat) +structural type NeedsA a b = NeedsA (A a b Nat Nat) | Zoink Text f : A Nat Nat Nat Nat -> Nat @@ -41,7 +41,7 @@ We'll make our edits in a fork of the `a` namespace: ⍟ I've added these definitions: unique type A a b c d - type NeedsA a b + structural type NeedsA a b f : A Nat Nat Nat Nat -> Nat f2 : A Nat Nat Nat Nat -> Nat f3 : NeedsA Nat Nat -> Nat @@ -74,9 +74,16 @@ Let's do the update now, and verify that the definitions all look good and there .a2> view A NeedsA f f2 f3 g - unique type A a b c d = E a d | C c | A a | B b | D d + unique type A a b c d + = E a d + | C c + | A a + | B b + | D d - type NeedsA a b = Zoink Text | NeedsA (A a b Nat Nat) + structural type NeedsA a b + = Zoink Text + | NeedsA (A a b Nat Nat) f : A Nat Nat Nat Nat -> Nat f = cases @@ -113,7 +120,7 @@ Let's do the update now, and verify that the definitions all look good and there Here's a test of updating a record: ```unison -type Rec = { uno : Nat, dos : Nat } +structural type Rec = { uno : Nat, dos : Nat } combine r = uno r + dos r ``` @@ -126,7 +133,7 @@ combine r = uno r + dos r ⍟ These new definitions are ok to `add`: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -143,7 +150,7 @@ combine r = uno r + dos r ⍟ I've added these definitions: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -154,7 +161,7 @@ combine r = uno r + dos r ``` ```unison -type Rec = { uno : Nat, dos : Nat, tres : Text } +structural type Rec = { uno : Nat, dos : Nat, tres : Text } ``` ```ucm @@ -172,7 +179,7 @@ type Rec = { uno : Nat, dos : Nat, tres : Text } ⍟ These names already exist. You can `update` them to your new definition: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec @@ -198,7 +205,7 @@ And checking that after updating this record, there's nothing `todo`: ⍟ I've updated these names to your new definition: - type Rec + structural type Rec Rec.dos : Rec -> Nat Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec Rec.dos.set : Nat -> Rec -> Rec diff --git a/unison-src/transcripts/fix689.md b/unison-src/transcripts/fix689.md index a156daa6aa..b22106eed4 100644 --- a/unison-src/transcripts/fix689.md +++ b/unison-src/transcripts/fix689.md @@ -5,7 +5,7 @@ Tests the fix for https://github.com/unisonweb/unison/issues/689 ``` ``` unison -ability SystemTime where +structural ability SystemTime where systemTime : ##Nat tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) diff --git a/unison-src/transcripts/fix689.output.md b/unison-src/transcripts/fix689.output.md index e4d39e5bcc..6f8b8db761 100644 --- a/unison-src/transcripts/fix689.output.md +++ b/unison-src/transcripts/fix689.output.md @@ -1,7 +1,7 @@ Tests the fix for https://github.com/unisonweb/unison/issues/689 ```unison -ability SystemTime where +structural ability SystemTime where systemTime : ##Nat tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) @@ -15,7 +15,7 @@ tomorrow = '(SystemTime.systemTime + 24 * 60 * 60) ⍟ These new definitions are ok to `add`: - ability SystemTime + structural ability SystemTime tomorrow : '{SystemTime} Nat ``` diff --git a/unison-src/transcripts/fix693.md b/unison-src/transcripts/fix693.md index 49661aff3f..bcb714af97 100644 --- a/unison-src/transcripts/fix693.md +++ b/unison-src/transcripts/fix693.md @@ -4,10 +4,10 @@ ``` ```unison -ability X t where +structural ability X t where x : t -> a -> a -ability Abort where +structural ability Abort where abort : a ``` diff --git a/unison-src/transcripts/fix693.output.md b/unison-src/transcripts/fix693.output.md index 327115d8fc..32fef56cd8 100644 --- a/unison-src/transcripts/fix693.output.md +++ b/unison-src/transcripts/fix693.output.md @@ -1,9 +1,9 @@ ```unison -ability X t where +structural ability X t where x : t -> a -> a -ability Abort where +structural ability Abort where abort : a ``` @@ -15,8 +15,8 @@ ability Abort where ⍟ These new definitions are ok to `add`: - ability Abort - ability X t + structural ability Abort + structural ability X t ``` ```ucm @@ -24,8 +24,8 @@ ability Abort where ⍟ I've added these definitions: - ability Abort - ability X t + structural ability Abort + structural ability X t ``` This code should not type check. The match on X.x ought to introduce a diff --git a/unison-src/transcripts/fix987.md b/unison-src/transcripts/fix987.md index 28e39518de..0db69b1d78 100644 --- a/unison-src/transcripts/fix987.md +++ b/unison-src/transcripts/fix987.md @@ -6,7 +6,7 @@ First we'll add a definition: ```unison -ability DeathStar where +structural ability DeathStar where attack : Text -> () spaceAttack1 x = diff --git a/unison-src/transcripts/fix987.output.md b/unison-src/transcripts/fix987.output.md index ecf3169535..f63416f521 100644 --- a/unison-src/transcripts/fix987.output.md +++ b/unison-src/transcripts/fix987.output.md @@ -2,7 +2,7 @@ First we'll add a definition: ```unison -ability DeathStar where +structural ability DeathStar where attack : Text -> () spaceAttack1 x = @@ -19,7 +19,7 @@ spaceAttack1 x = ⍟ These new definitions are ok to `add`: - ability DeathStar + structural ability DeathStar spaceAttack1 : x ->{DeathStar} Text ``` @@ -30,7 +30,7 @@ Add it to the codebase: ⍟ I've added these definitions: - ability DeathStar + structural ability DeathStar spaceAttack1 : x ->{DeathStar} Text ``` From 4001b911a127093a73c4138575e005c2ed651abe Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 24 Aug 2021 11:43:40 -0700 Subject: [PATCH 011/148] adds transcript test for structural/unique modifier --- .../transcripts/type-modifier-required.md | 26 ++++++++ .../type-modifier-required.output.md | 62 +++++++++++++++++++ 2 files changed, 88 insertions(+) create mode 100644 unison-src/transcripts/type-modifier-required.md create mode 100644 unison-src/transcripts/type-modifier-required.output.md diff --git a/unison-src/transcripts/type-modifier-required.md b/unison-src/transcripts/type-modifier-required.md new file mode 100644 index 0000000000..01381a5bfb --- /dev/null +++ b/unison-src/transcripts/type-modifier-required.md @@ -0,0 +1,26 @@ +# Type modifiers are required + +```ucm:hide +.> builtins.merge +``` + +Types needs to be prefixed with either `unique` or `structural`: + +```unison:error +type Abc = Abc +``` + +Abilities needs to be prefixed with either `unique` or `structural`: + +```unison:error +ability MyAbility where const : a +``` + +There should be no errors when `unique` or `structural` is provided: + +```unison +structural type AbcS = AbcSg +unique type AbcU = AbcU +structural ability MyAbilityS where const : a +unique ability MyAbilityU where const : a +``` \ No newline at end of file diff --git a/unison-src/transcripts/type-modifier-required.output.md b/unison-src/transcripts/type-modifier-required.output.md new file mode 100644 index 0000000000..accdb1732f --- /dev/null +++ b/unison-src/transcripts/type-modifier-required.output.md @@ -0,0 +1,62 @@ +# Type modifiers are required + +Types needs to be prefixed with either `unique` or `structural`: + +```unison +type Abc = Abc +``` + +```ucm + + I expected to see `structural` or `unique` at the start of + this line: + + 1 | type Abc = Abc + + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types + +``` +Abilities needs to be prefixed with either `unique` or `structural`: + +```unison +ability MyAbility where const : a +``` + +```ucm + + I expected to see `structural` or `unique` at the start of + this line: + + 1 | ability MyAbility where const : a + + Learn more about when to use `structural` vs `unique` in the + Unison Docs: + https://www.unisonweb.org/docs/language-reference/#unique-types + +``` +There should be no errors when `unique` or `structural` is provided: + +```unison +structural type AbcS = AbcS +unique type AbcU = AbcU +structural ability MyAbilityS where const : a +unique ability MyAbilityU where const : a +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type AbcS + (also named builtin.Unit) + unique type AbcU + structural ability MyAbilityS + unique ability MyAbilityU + +``` From 726a171b683655795831ede489b948944018c768 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 24 Aug 2021 13:04:58 -0700 Subject: [PATCH 012/148] typo fix + slight output changes --- .../transcripts-using-base/fix2027.output.md | 23 +++++++++++-------- .../transcripts/type-modifier-required.md | 2 +- .../type-modifier-required.output.md | 2 +- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/unison-src/transcripts-using-base/fix2027.output.md b/unison-src/transcripts-using-base/fix2027.output.md index de62d3c43b..c598d513e1 100644 --- a/unison-src/transcripts-using-base/fix2027.output.md +++ b/unison-src/transcripts-using-base/fix2027.output.md @@ -52,29 +52,34 @@ myServer = unsafeRun! '(hello "127.0.0.1" "0") do an `add` or `update`, here's how your codebase would change: + ⊡ Previously added definitions will be ignored: Exception + Exception.raise + ⍟ These new definitions are ok to `add`: structural type Either a b (also named builtin.Either) - structural ability Exception - (also named builtin.Exception) Exception.unsafeRun! : '{g, Exception} a -> '{g} a bugFail : Failure -> r - closeSocket : Socket ->{IO, Exception} () hello : Text -> Text ->{IO, Exception} () myServer : '{IO} () - putBytes : Handle - -> Bytes - ->{IO, Exception} () putText : Handle -> Text ->{IO, Exception} () reraise : Either Failure b ->{Exception} b - serverSocket : Optional Text - -> Text - ->{IO, Exception} Socket + (also named Exception.reraise) socketSend : Socket -> Bytes ->{IO, Exception} () toException : Either Failure a ->{Exception} a + (also named Exception.reraise) + + ⍟ These names already exist. You can `update` them to your + new definition: + + closeSocket : Socket ->{IO, Exception} () + putBytes : Handle -> Bytes ->{IO, Exception} () + serverSocket : Optional Text + -> Text + ->{IO, Exception} Socket ``` ```ucm diff --git a/unison-src/transcripts/type-modifier-required.md b/unison-src/transcripts/type-modifier-required.md index 01381a5bfb..1b47bf78e7 100644 --- a/unison-src/transcripts/type-modifier-required.md +++ b/unison-src/transcripts/type-modifier-required.md @@ -19,7 +19,7 @@ ability MyAbility where const : a There should be no errors when `unique` or `structural` is provided: ```unison -structural type AbcS = AbcSg +structural type AbcS = AbcS unique type AbcU = AbcU structural ability MyAbilityS where const : a unique ability MyAbilityU where const : a diff --git a/unison-src/transcripts/type-modifier-required.output.md b/unison-src/transcripts/type-modifier-required.output.md index accdb1732f..656898f3c0 100644 --- a/unison-src/transcripts/type-modifier-required.output.md +++ b/unison-src/transcripts/type-modifier-required.output.md @@ -39,7 +39,7 @@ ability MyAbility where const : a There should be no errors when `unique` or `structural` is provided: ```unison -structural type AbcS = AbcS +structural type AbcS = AbcSg unique type AbcU = AbcU structural ability MyAbilityS where const : a unique ability MyAbilityU where const : a From 3fdf758b377b37ed7fe4133c1d4a8a6f817fdf2e Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 24 Aug 2021 13:23:19 -0700 Subject: [PATCH 013/148] empty to trigger build From b2cd7153d341606121447310482623357be5797a Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 24 Aug 2021 13:38:02 -0700 Subject: [PATCH 014/148] weird extra character???? --- unison-src/transcripts/type-modifier-required.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/type-modifier-required.output.md b/unison-src/transcripts/type-modifier-required.output.md index 656898f3c0..accdb1732f 100644 --- a/unison-src/transcripts/type-modifier-required.output.md +++ b/unison-src/transcripts/type-modifier-required.output.md @@ -39,7 +39,7 @@ ability MyAbility where const : a There should be no errors when `unique` or `structural` is provided: ```unison -structural type AbcS = AbcSg +structural type AbcS = AbcS unique type AbcU = AbcU structural ability MyAbilityS where const : a unique ability MyAbilityU where const : a From 2286d20c41b8a3e77629f294e2224f1876ce97f4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 26 Aug 2021 16:02:16 -0400 Subject: [PATCH 015/148] Add a test case --- unison-src/transcripts/fix2344.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 unison-src/transcripts/fix2344.md diff --git a/unison-src/transcripts/fix2344.md b/unison-src/transcripts/fix2344.md new file mode 100644 index 0000000000..6dd1e0ca21 --- /dev/null +++ b/unison-src/transcripts/fix2344.md @@ -0,0 +1,22 @@ + +Checks a corner case with type checking involving destructuring binds. + +The binds were causing some sequences of lets to be unnecessarily +recursive. + +```ucm:hide +.> builtins.merge +``` + +```unison +unique ability Nate where + nate: (Boolean, Nat) + antiNate: () + + +sneezy: (Nat -> {d} a) -> '{Nate,d} a +sneezy dee _ = + (_,_) = nate + antiNate + dee 1 +``` From 85435c3c3c6cd89d29f51b95be0100458ec13dc2 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 26 Aug 2021 16:24:48 -0400 Subject: [PATCH 016/148] Call minimize' underneath each destructuring bind - Failing to do this was causing destructuring binds to make other bindings unnecessarily recursive, because the minimzation that splits things back into non-recursive parts was only getting called on the finished term, and a destructuring bind breaks up/hides the letrec subject to minimization --- parser-typechecker/src/Unison/TermParser.hs | 29 ++++++++++++--------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 3103b38675..2799e27409 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -11,6 +11,7 @@ module Unison.TermParser where import Unison.Prelude import Control.Monad.Reader (asks, local) +import Data.Foldable (foldrM) import Prelude hiding (and, or, seq) import Unison.Name (Name) import Unison.Names3 (Names) @@ -1038,21 +1039,23 @@ block'' isTop implicitUnitAtEnd s openBlock closeBlock = do Right tm -> pure tm toTm bs = do (bs, body) <- body bs - finish $ foldr step body bs + finish =<< foldrM step body bs where - step :: BlockElement v -> Term v Ann -> Term v Ann step elem body = case elem of - Binding ((a,v), tm) -> Term.consLetRec - isTop - (ann a <> ann body) - (a,v,tm) - body - Action tm -> Term.consLetRec - isTop - (ann tm <> ann body) - (ann tm, positionalVar (ann tm) (Var.named "_"), tm) - body - DestructuringBind (_, f) -> f body + Binding ((a,v), tm) -> pure $ + Term.consLetRec + isTop + (ann a <> ann body) + (a,v,tm) + body + Action tm -> pure $ + Term.consLetRec + isTop + (ann tm <> ann body) + (ann tm, positionalVar (ann tm) (Var.named "_"), tm) + body + DestructuringBind (_, f) -> + f <$> finish body body bs = case reverse bs of Binding ((a, _v), _) : _ -> pure $ if implicitUnitAtEnd then (bs, DD.unitTerm a) From 2f13ea1f84e24d098c02fe2958362090184de09d Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 27 Jul 2021 13:42:21 -0700 Subject: [PATCH 017/148] stripping and unknotting some stuff - moved everything that depended on V1 `Reference` into `FileCodebase` namespace, duplicating a lot of code for better or worse. - pulled these into their own modules: - Codebase (types) into `Codebase.Type`; `Codebase` module re-exports them - `Codebase.Branch.Merge`, - `Codebase.Branch.Names` (Branch shouldn't depend on `Names`) - `Codebase.BuiltinAnnotation` - `Codebase.Causal.FoldHistory` - `Codebase.CodeLookup.Util` (remove `CodeLookup` dependency on `UnisonFile`) - `Codebase.DataDeclaration.ConstructorId` trying to use this alias in relevant places - `Codebase.Init` - `CodebasePath`, the `FilePath` alias. - `Lexer.Pos` (because `AnnotatedText`, `Range`, `Parser.Ann` shouldn't depend on the whole lexer) - `Names.ResolutionResult` (`Type` shouldn't depend on `Names`) - `PrettyPrintEnv.FQN` - `PrettyPrintEnv.Names` (pulled out references to `Names` from `PPE`) - `PPE.Util` not 100% sure what's happening here - `PrettyPrintEnvDecl` pull this data type and supporting functions into separate module - `Path.Parse` (`Path` shouldn't depend on the lexer) - `Path.Convert`, `Path.Parse` into `Unison.Util.Convert` - `Parser.Ann` (`Codebase`, etc. etc. shouldn't depend on `Parser`) - `Referent'` (`SyntaxText`/`ColorText` shouldn't depend on `Reference`) - `Referent` module re-exports stuff from `Referent'`, hard-coded to `Reference`. - removed `SyntaxText.SyntaxText` - `TermEdit.Typing` (because `TermEdit` shouldn't depend on the full typechecker) - `UnisonFile` / `TypecheckedUnisonFile` (types into `UnisonFile.Type`) - `UnisonFile.Env` - `UnisonFile.Error` - `UnisonFile.Names` - `Var.WatchKind` - `Var.refNamed` - Deleted unused `Codebase.Classes` typeclasses wip - Deleted unused `Unison.Util.Menu`, ancient modal stuff - Moved `Codebase.makeSelfContained` into `UnisonFile` module, since it deals with `UnisonFile` and not with `Codebase`. - split up `GitError` into a more codebase-agnostic hierarchy (see `Codebase.Type.GitError`) - changed `bindNames` to `bindReferences` in some cases; `bindNames` remains in `.Names` compatibility module - move `Unison.Var.refNamed` into `Unison.Term` - tweaked GitError to separate obviously codebase-format specific errors from non-obviously-corbase-format-specific errors. - tweaked `Reflog.Entry` to support anything that's coercible to `Unison.Hash`, but also changed its kind - removed `DebugBranchHistoryI` input because I didn't want to maintain its implementation - removed `ShortBranchHash` dependency on `Hash`, and let it work on anything coercible to `Hash`. P.S./todo This class should be called ShortHash; the existing ShortHash is really a ShortReference! - removed SyntaxText dependency on Reference - cleaned up `Path` somewhat - held off on: - move `DD.updateDependencies` - splitting up `Path` into the billion different components - e.g. `Path` becomes `RelativePath`, `Path'` becomes `Path`, and `Absolute` wraps `RelativePath` - `Split` / `Split'` maybe rename to `Path.NonEmpty`? - rename `Branch.getPatch` / `.getMaybePatch` - split out `Name.Parse`, `Name.Convert`, substitute a lot of specific functions like `Path.hqSplitFromName'` with `Convert.parse`. - todo: - clear unreferenced junk - restore: - `NameEdit`? - `PatternCompat`? --- parser-typechecker/package.yaml | 1 + parser-typechecker/src/Unison/Builtin.hs | 2 +- .../src/Unison/Builtin/Decls.hs | 4 +- parser-typechecker/src/Unison/Codebase.hs | 341 ++--- .../src/Unison/Codebase/Branch.hs | 468 ++----- .../src/Unison/Codebase/Branch/Merge.hs | 756 +++++++++++ .../src/Unison/Codebase/Branch/Names.hs | 771 ++++++++++++ .../src/Unison/Codebase/BuiltinAnnotation.hs | 13 + .../src/Unison/Codebase/Causal.hs | 133 +- .../src/Unison/Codebase/Causal/FoldHistory.hs | 51 + .../src/Unison/Codebase/Classes.hs | 40 - .../src/Unison/Codebase/CodeLookup.hs | 61 +- .../src/Unison/Codebase/CodeLookup/Util.hs | 30 + .../src/Unison/Codebase/Conversion/Sync12.hs | 2 +- .../Unison/Codebase/Conversion/Upgrade12.hs | 73 -- .../src/Unison/Codebase/Editor/Command.hs | 13 +- .../src/Unison/Codebase/Editor/Git.hs | 22 +- .../Unison/Codebase/Editor/HandleCommand.hs | 25 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 25 +- .../src/Unison/Codebase/Editor/Input.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 9 +- .../src/Unison/Codebase/Editor/Propagate.hs | 4 +- .../src/Unison/Codebase/Editor/SlurpResult.hs | 3 +- .../src/Unison/Codebase/Execute.hs | 3 +- .../src/Unison/Codebase/FileCodebase.hs | 73 +- .../Unison/Codebase/FileCodebase/Branch.hs | 783 ++++++++++++ .../FileCodebase/Branch/Dependencies.hs | 39 +- .../Unison/Codebase/FileCodebase/Codebase.hs | 109 ++ .../Unison/Codebase/FileCodebase/Common.hs | 105 +- .../Codebase/FileCodebase/DataDeclaration.hs | 117 ++ .../src/Unison/Codebase/FileCodebase/Init.hs | 27 + .../FileCodebase/LabeledDependency.hs | 56 + .../Unison/Codebase/FileCodebase/Metadata.hs | 80 ++ .../src/Unison/Codebase/FileCodebase/Patch.hs | 136 ++ .../Unison/Codebase/FileCodebase/Pattern.hs | 165 +++ .../Unison/Codebase/FileCodebase/Reference.hs | 192 +++ .../Codebase/FileCodebase/Reference/Util.hs | 21 + .../Unison/Codebase/FileCodebase/Referent.hs | 124 ++ .../{ => FileCodebase}/Serialization/V1.hs | 172 +-- .../FileCodebase/SlimCopyRegenerateIndex.hs | 67 +- .../src/Unison/Codebase/FileCodebase/Term.hs | 1120 +++++++++++++++++ .../Unison/Codebase/FileCodebase/TermEdit.hs | 42 + .../src/Unison/Codebase/FileCodebase/Type.hs | 709 +++++++++++ .../Unison/Codebase/FileCodebase/TypeEdit.hs | 20 + .../src/Unison/Codebase/GitError.hs | 39 +- .../src/Unison/Codebase/Init.hs | 35 +- .../Codebase/Init/CreateCodebaseError.hs | 12 + .../src/Unison/Codebase/Init/Type.hs | 20 + .../src/Unison/Codebase/MainTerm.hs | 5 +- .../src/Unison/Codebase/NameEdit.hs | 15 - .../src/Unison/Codebase/Path.hs | 65 +- .../src/Unison/Codebase/Path/Parse.hs | 258 ++++ .../src/Unison/Codebase/Reflog.hs | 31 +- .../src/Unison/Codebase/Runtime.hs | 20 +- .../src/Unison/Codebase/Serialization/PutT.hs | 57 - .../src/Unison/Codebase/ShortBranchHash.hs | 15 +- .../src/Unison/Codebase/SqliteCodebase.hs | 56 +- .../Codebase/SqliteCodebase/Conversions.hs | 20 +- .../Codebase/SqliteCodebase/GitError.hs | 10 + .../src/Unison/Codebase/TermEdit.hs | 9 - .../src/Unison/Codebase/TermEdit/Typing.hs | 12 + .../src/Unison/Codebase/TranscriptParser.hs | 3 +- .../src/Unison/Codebase/Type.hs | 101 ++ parser-typechecker/src/Unison/CodebasePath.hs | 13 + .../src/Unison/CommandLine/DisplayValues.hs | 2 + .../src/Unison/CommandLine/InputPatterns.hs | 3 + .../src/Unison/CommandLine/Main.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 153 +-- parser-typechecker/src/Unison/DeclPrinter.hs | 3 +- parser-typechecker/src/Unison/FileParser.hs | 7 +- parser-typechecker/src/Unison/FileParsers.hs | 4 +- parser-typechecker/src/Unison/Lexer.hs | 22 +- parser-typechecker/src/Unison/Lexer/Pos.hs | 29 + parser-typechecker/src/Unison/NamePrinter.hs | 3 +- parser-typechecker/src/Unison/Parser.hs | 26 +- parser-typechecker/src/Unison/Parser/Ann.hs | 29 + parser-typechecker/src/Unison/Parsers.hs | 2 +- parser-typechecker/src/Unison/Path.hs | 54 - .../src/Unison/PrettyPrintEnv.hs | 74 +- .../src/Unison/PrettyPrintEnv/FQN.hs | 32 + .../src/Unison/PrettyPrintEnv/Names.hs | 144 +++ .../src/Unison/PrettyPrintEnv/Util.hs | 110 ++ .../src/Unison/PrettyPrintEnvDecl.hs | 18 + .../src/Unison/PrettyPrintEnvDecl/Names.hs | 11 + parser-typechecker/src/Unison/PrintError.hs | 8 +- parser-typechecker/src/Unison/Result.hs | 2 +- .../src/Unison/Runtime/ANF/Serialize.hs | 202 ++- .../src/Unison/Runtime/IOSource.hs | 5 +- .../src/Unison/Runtime/Interface.hs | 3 +- .../src/Unison/Runtime/Pattern.hs | 5 +- .../src/Unison/Server/Backend.hs | 22 +- .../src/Unison/Server/CodebaseServer.hs | 2 +- parser-typechecker/src/Unison/Server/Doc.hs | 7 +- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 3 +- .../Unison/Server/Endpoints/GetDefinitions.hs | 3 +- .../Unison/Server/Endpoints/ListNamespace.hs | 3 +- parser-typechecker/src/Unison/TermParser.hs | 1 + parser-typechecker/src/Unison/TermPrinter.hs | 8 +- parser-typechecker/src/Unison/TypeParser.hs | 1 + parser-typechecker/src/Unison/TypePrinter.hs | 8 +- .../src/Unison/Typechecker/TypeLookup.hs | 6 +- parser-typechecker/src/Unison/UnisonFile.hs | 204 ++- .../src/Unison/UnisonFile/Env.hs | 30 + .../src/Unison/UnisonFile/Error.hs | 14 + .../src/Unison/UnisonFile/Names.hs | 145 +++ .../src/Unison/UnisonFile/Type.hs | 50 + .../src/Unison/Util/AnnotatedText.hs | 2 +- parser-typechecker/src/Unison/Util/Convert.hs | 10 + parser-typechecker/src/Unison/Util/Menu.hs | 286 ----- parser-typechecker/src/Unison/Util/Pretty.hs | 2 +- parser-typechecker/src/Unison/Util/Range.hs | 2 +- .../src/Unison/Util/SyntaxText.hs | 4 +- parser-typechecker/tests/Suite.hs | 7 - parser-typechecker/tests/Unison/Test/ABT.hs | 11 +- .../Unison/Test/BaseUpgradePushPullTest.hs | 43 - .../tests/Unison/Test/ClearCache.hs | 2 +- .../tests/Unison/Test/Codebase.hs | 40 - .../tests/Unison/Test/Codebase/Causal.hs | 1 + .../Unison/Test/Codebase/FileCodebase.hs | 48 - .../tests/Unison/Test/Codebase/Path.hs | 1 + .../tests/Unison/Test/Codebase/Upgrade12.hs | 243 ---- .../tests/Unison/Test/Common.hs | 2 +- .../tests/Unison/Test/DataDeclaration.hs | 5 +- .../tests/Unison/Test/FileParser.hs | 1 + .../tests/Unison/Test/GitSync.hs | 6 +- parser-typechecker/tests/Unison/Test/Term.hs | 1 + .../tests/Unison/Test/TermPrinter.hs | 3 +- .../tests/Unison/Test/TypePrinter.hs | 1 + .../Unison/Test/Typechecker/TypeError.hs | 2 +- parser-typechecker/tests/Unison/Test/Ucm.hs | 17 +- .../tests/Unison/Test/UnisonSources.hs | 46 +- .../unison-parser-typechecker.cabal | 52 +- parser-typechecker/unison/Main.hs | 11 +- unison-core/src/Unison/DataDeclaration.hs | 83 +- .../Unison/DataDeclaration/ConstructorId.hs | 11 + .../src/Unison/DataDeclaration/Names.hs | 61 + unison-core/src/Unison/HashQualified'.hs | 12 +- unison-core/src/Unison/HashQualified.hs | 26 +- unison-core/src/Unison/LabeledDependency.hs | 10 +- unison-core/src/Unison/Name.hs | 96 +- unison-core/src/Unison/NameSegment.hs | 23 + .../src/Unison/Names/ResolutionResult.hs | 16 + unison-core/src/Unison/Names2.hs | 33 +- unison-core/src/Unison/Names3.hs | 35 +- unison-core/src/Unison/Pattern.hs | 17 +- unison-core/src/Unison/PatternCompat.hs | 30 - unison-core/src/Unison/Reference/Util.hs | 5 +- unison-core/src/Unison/Referent'.hs | 51 + unison-core/src/Unison/Referent.hs | 71 +- unison-core/src/Unison/Term.hs | 30 +- unison-core/src/Unison/Type.hs | 21 +- unison-core/src/Unison/Type/Names.hs | 47 + unison-core/src/Unison/Util/Alphabetical.hs | 29 + unison-core/src/Unison/Util/Relation.hs | 38 + unison-core/src/Unison/Var.hs | 14 +- unison-core/src/Unison/Var/RefNamed.hs | 13 + unison-core/src/Unison/WatchKind.hs | 11 + unison-core/unison-core1.cabal | 11 +- 158 files changed, 8234 insertions(+), 2676 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/Branch/Merge.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Branch/Names.hs create mode 100644 parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/Classes.hs create mode 100644 parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs rename parser-typechecker/src/Unison/Codebase/{ => FileCodebase}/Serialization/V1.hs (84%) create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Init/Type.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/NameEdit.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Path/Parse.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs create mode 100644 parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs create mode 100644 parser-typechecker/src/Unison/Codebase/Type.hs create mode 100644 parser-typechecker/src/Unison/CodebasePath.hs create mode 100644 parser-typechecker/src/Unison/Lexer/Pos.hs create mode 100644 parser-typechecker/src/Unison/Parser/Ann.hs delete mode 100644 parser-typechecker/src/Unison/Path.hs create mode 100644 parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs create mode 100644 parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs create mode 100644 parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs create mode 100644 parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs create mode 100644 parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs create mode 100644 parser-typechecker/src/Unison/UnisonFile/Env.hs create mode 100644 parser-typechecker/src/Unison/UnisonFile/Error.hs create mode 100644 parser-typechecker/src/Unison/UnisonFile/Names.hs create mode 100644 parser-typechecker/src/Unison/UnisonFile/Type.hs create mode 100644 parser-typechecker/src/Unison/Util/Convert.hs delete mode 100644 parser-typechecker/src/Unison/Util/Menu.hs delete mode 100644 parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs delete mode 100644 parser-typechecker/tests/Unison/Test/Codebase.hs delete mode 100644 parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs delete mode 100644 parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs mode change 100755 => 100644 parser-typechecker/tests/Unison/Test/TermPrinter.hs mode change 100755 => 100644 parser-typechecker/tests/Unison/Test/TypePrinter.hs create mode 100644 unison-core/src/Unison/DataDeclaration/ConstructorId.hs create mode 100644 unison-core/src/Unison/DataDeclaration/Names.hs create mode 100644 unison-core/src/Unison/Names/ResolutionResult.hs delete mode 100644 unison-core/src/Unison/PatternCompat.hs create mode 100644 unison-core/src/Unison/Referent'.hs create mode 100644 unison-core/src/Unison/Type/Names.hs create mode 100644 unison-core/src/Unison/Util/Alphabetical.hs create mode 100644 unison-core/src/Unison/Var/RefNamed.hs create mode 100644 unison-core/src/Unison/WatchKind.hs diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index f4c8868b6d..6b244bcea7 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -75,6 +75,7 @@ library: - openapi3 - optparse-applicative - pem + - prelude-extras - process - primitive - random >= 1.2.0 diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 09db6252e0..69819b9864 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -33,7 +33,7 @@ import Unison.Codebase.CodeLookup ( CodeLookup(..) ) import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as TD import qualified Unison.DataDeclaration as DD -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann (..)) import qualified Unison.Reference as R import qualified Unison.Referent as Referent import Unison.Symbol ( Symbol ) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index 4acb14b3ab..a0296d9cd8 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -18,10 +18,10 @@ import qualified Unison.DataDeclaration as DD import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import Unison.Referent (Referent) +import Unison.Referent (Referent, ConstructorId) import qualified Unison.Referent as Referent import Unison.Symbol (Symbol) -import Unison.Term (ConstructorId, Term, Term2) +import Unison.Term (Term, Term2) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 5dfd963b76..f0ad4296d4 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,130 +1,63 @@ {-# LANGUAGE OverloadedStrings #-} - {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase where -import Control.Lens ((%=), _1, _2) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.State (State, evalState, get) -import Data.Bifunctor (bimap) +module Unison.Codebase + ( Codebase (..), + CodebasePath, + GetRootBranchError (..), + getCodebaseDir, + SyncToDir, + addDefsToCodebase, + installUcmDependencies, + getTypeOfTerm, + getTypeOfReferent, + lca, + lookupWatchCache, + toCodeLookup, + typeLookupForDependencies, + importRemoteBranch, + viewRemoteBranch, + termsOfType, + termsMentioningType, + dependents, + isTerm, + isType, + ) +where + +import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), SyncToDir, GitError (GitCodebaseError)) +import Unison.CodebasePath (CodebasePath, getCodebaseDir) +import Unison.Prelude +import qualified Unison.UnisonFile as UF import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Unison.ABT as ABT -import qualified Unison.Builtin as Builtin +import Unison.Symbol (Symbol) +import qualified Unison.Parser.Ann as Parser import qualified Unison.Builtin.Terms as Builtin -import Unison.Codebase.Branch (Branch) -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.CodeLookup as CL -import Unison.Codebase.Editor.Git (withStatus) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo) -import Unison.Codebase.GitError (GitError) -import Unison.Codebase.Patch (Patch) -import qualified Unison.Codebase.Reflog as Reflog -import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import Unison.Codebase.SyncMode (SyncMode) +import qualified Unison.Builtin as Builtin import Unison.DataDeclaration (Decl) -import qualified Unison.DataDeclaration as DD -import qualified Unison.Parser as Parser -import Unison.Prelude -import Unison.Reference (Reference) import qualified Unison.Reference as Reference +import Unison.Var (Var) +import Unison.Reference (Reference) +import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) +import Unison.Type (Type) import qualified Unison.Referent as Referent -import Unison.ShortHash (ShortHash) -import Unison.Symbol (Symbol) +import qualified Unison.DataDeclaration as DD +import qualified Unison.Codebase.CodeLookup as CL +import qualified Unison.WatchKind as WK import Unison.Term (Term) -import qualified Unison.Term as Term -import Unison.Type (Type) -import qualified Unison.Type as Type -import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup)) import qualified Unison.Typechecker.TypeLookup as TL -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Relation as Rel -import qualified Unison.Util.Set as Set -import U.Util.Timing (time) -import Unison.Var (Var) -import qualified Unison.Var as Var -import UnliftIO.Directory (getHomeDirectory) +import Unison.Typechecker.TypeLookup (TypeLookup(TypeLookup)) +import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.Branch (Branch) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Control.Monad.Except (runExceptT, ExceptT (ExceptT)) +import Unison.Codebase.SyncMode (SyncMode) import qualified Unison.Codebase.GitError as GitError - -type DataDeclaration v a = DD.DataDeclaration v a - -type EffectDeclaration v a = DD.EffectDeclaration v a - --- | this FileCodebase detail lives here, because the interface depends on it 🙃 -type CodebasePath = FilePath - -type SyncToDir m = - CodebasePath -> -- dest codebase - SyncMode -> - Branch m -> -- branch to sync to dest codebase - m () - --- | Abstract interface to a user's codebase. --- --- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. -data Codebase m v a = - Codebase { getTerm :: Reference.Id -> m (Maybe (Term v a)) - , getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)) - , getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)) - - , putTerm :: Reference.Id -> Term v a -> Type v a -> m () - , putTypeDeclaration :: Reference.Id -> Decl v a -> m () - - , getRootBranch :: m (Either GetRootBranchError (Branch m)) - , putRootBranch :: Branch m -> m () - , rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)) - , getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) - , putBranch :: Branch m -> m () - , branchExists :: Branch.Hash -> m Bool - - , getPatch :: Branch.EditHash -> m (Maybe Patch) - , putPatch :: Branch.EditHash -> Patch -> m () - , patchExists :: Branch.EditHash -> m Bool - - , dependentsImpl :: Reference -> m (Set Reference.Id) - -- This copies all the dependencies of `b` from the specified Codebase into this one - , syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m () - -- This copies all the dependencies of `b` from this Codebase - , syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m () - , viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)) - , pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()) - - -- Watch expressions are part of the codebase, the `Reference.Id` is - -- the hash of the source of the watch expression, and the `Term v a` - -- is the evaluated result of the expression, decompiled to a term. - , watches :: UF.WatchKind -> m [Reference.Id] - , getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term v a)) - , putWatch :: UF.WatchKind -> Reference.Id -> Term v a -> m () - , clearWatches :: m () - - , getReflog :: m [Reflog.Entry] - , appendReflog :: Text -> Branch m -> Branch m -> m () - - -- list of terms of the given type - , termsOfTypeImpl :: Reference -> m (Set Referent.Id) - -- list of terms that mention the given type anywhere in their signature - , termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) - -- number of base58 characters needed to distinguish any two references in the codebase - , hashLength :: m Int - , termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - , typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - , termReferentsByPrefix :: ShortHash -> m (Set Referent.Id) - - , branchHashLength :: m Int - , branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) - - -- returns `Nothing` to not implemented, fallback to in-memory - -- also `Nothing` if no LCA - -- The result is undefined if the two hashes are not in the codebase. - -- Use `Codebase.lca` which wraps this in a nice API. - , lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)) - - -- `beforeImpl` returns `Nothing` if not implemented by the codebase - -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase - -- - -- Use `Codebase.before` which wraps this in a nice API. - , beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) - } +import U.Util.Timing (time) +import Unison.Codebase.Editor.Git (withStatus) +import qualified Data.Set as Set +import qualified Unison.Util.Relation as Rel +import qualified Unison.Type as Type lca :: Monad m => Codebase m v a -> Branch m -> Branch m -> m (Maybe (Branch m)) lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = case lcaImpl code of @@ -138,35 +71,35 @@ lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = case lcaImpl co Nothing -> pure Nothing -- no common ancestor else Branch.lca b1 b2 -before :: Monad m => Codebase m v a -> Branch m -> Branch m -> m Bool -before code b1 b2 = case beforeImpl code of - Nothing -> Branch.before b1 b2 - Just before -> before' (branchExists code) before b1 b2 +-- before :: Monad m => Codebase m v a -> Branch m -> Branch m -> m Bool +-- before code b1 b2 = case beforeImpl code of +-- Nothing -> Branch.before b1 b2 +-- Just before -> before' (branchExists code) before b1 b2 -before' :: Monad m => (Branch.Hash -> m Bool) -> (Branch.Hash -> Branch.Hash -> m Bool) -> Branch m -> Branch m -> m Bool -before' branchExists before b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = - ifM - (branchExists h2) - (ifM - (branchExists h2) - (before h1 h2) - (pure False)) - (Branch.before b1 b2) +-- before' :: Monad m => (Branch.Hash -> m Bool) -> (Branch.Hash -> Branch.Hash -> m Bool) -> Branch m -> Branch m -> m Bool +-- before' branchExists before b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = +-- ifM +-- (branchExists h2) +-- (ifM +-- (branchExists h2) +-- (before h1 h2) +-- (pure False)) +-- (Branch.before b1 b2) -data GetRootBranchError - = NoRootBranch - | CouldntParseRootBranch String - | CouldntLoadRootBranch Branch.Hash - deriving Show +-- data GetRootBranchError +-- = NoRootBranch +-- | CouldntParseRootBranch String +-- | CouldntLoadRootBranch Branch.Hash +-- deriving Show debug :: Bool debug = False -data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward +-- data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward -getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath -getCodebaseDir = maybe getHomeDirectory pure +-- getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath +-- getCodebaseDir = maybe getHomeDirectory pure -- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m () @@ -205,8 +138,8 @@ getTypeOfConstructor _ r cid = lookupWatchCache :: (Monad m) => Codebase m v a -> Reference -> m (Maybe (Term v a)) lookupWatchCache codebase (Reference.DerivedId h) = do - m1 <- getWatch codebase UF.RegularWatch h - maybe (getWatch codebase UF.TestWatch h) (pure . Just) m1 + m1 <- getWatch codebase WK.RegularWatch h + maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1 lookupWatchCache _ Reference.Builtin{} = pure Nothing typeLookupForDependencies @@ -227,99 +160,35 @@ typeLookupForDependencies codebase s = do Nothing -> pure mempty go tl Reference.Builtin{} = pure tl -- codebase isn't consulted for builtins --- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? --- todo: add some tests on this guy? -transitiveDependencies - :: (Monad m, Var v) - => CL.CodeLookup v m a - -> Set Reference.Id - -> Reference.Id - -> m (Set Reference.Id) -transitiveDependencies code seen0 rid = if Set.member rid seen0 - then pure seen0 - else - let seen = Set.insert rid seen0 - getIds = Set.mapMaybe Reference.toId - in CL.getTerm code rid >>= \case - Just t -> - foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) - Nothing -> - CL.getTypeDeclaration code rid >>= \case - Nothing -> pure seen - Just (Left ed) -> foldM (transitiveDependencies code) - seen - (getIds $ DD.dependencies (DD.toDataDecl ed)) - Just (Right dd) -> foldM (transitiveDependencies code) - seen - (getIds $ DD.dependencies dd) +-- -- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? +-- -- todo: add some tests on this guy? +-- transitiveDependencies +-- :: (Monad m, Var v) +-- => CL.CodeLookup v m a +-- -> Set Reference.Id +-- -> Reference.Id +-- -> m (Set Reference.Id) +-- transitiveDependencies code seen0 rid = if Set.member rid seen0 +-- then pure seen0 +-- else +-- let seen = Set.insert rid seen0 +-- getIds = Set.mapMaybe Reference.toId +-- in CL.getTerm code rid >>= \case +-- Just t -> +-- foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) +-- Nothing -> +-- CL.getTypeDeclaration code rid >>= \case +-- Nothing -> pure seen +-- Just (Left ed) -> foldM (transitiveDependencies code) +-- seen +-- (getIds $ DD.dependencies (DD.toDataDecl ed)) +-- Just (Right dd) -> foldM (transitiveDependencies code) +-- seen +-- (getIds $ DD.dependencies dd) toCodeLookup :: Codebase m v a -> CL.CodeLookup v m a toCodeLookup c = CL.CodeLookup (getTerm c) (getTypeDeclaration c) --- Like the other `makeSelfContained`, but takes and returns a `UnisonFile`. --- Any watches in the input `UnisonFile` will be watches in the returned --- `UnisonFile`. -makeSelfContained' - :: forall m v a . (Monad m, Monoid a, Var v) - => CL.CodeLookup v m a - -> UF.UnisonFile v a - -> m (UF.UnisonFile v a) -makeSelfContained' code uf = do - let UF.UnisonFileId ds0 es0 bs0 ws0 = uf - deps0 = getIds . Term.dependencies . snd <$> (UF.allWatches uf <> bs0) - where getIds = Set.mapMaybe Reference.toId - -- transitive dependencies (from codebase) of all terms (including watches) in the UF - deps <- foldM (transitiveDependencies code) Set.empty (Set.unions deps0) - -- load all decls from deps list - decls <- fmap catMaybes - . forM (toList deps) - $ \rid -> fmap (rid, ) <$> CL.getTypeDeclaration code rid - -- partition the decls into effects and data - let es1 :: [(Reference.Id, DD.EffectDeclaration v a)] - ds1 :: [(Reference.Id, DD.DataDeclaration v a)] - (es1, ds1) = partitionEithers [ bimap (r,) (r,) d | (r, d) <- decls ] - -- load all terms from deps list - bs1 <- fmap catMaybes - . forM (toList deps) - $ \rid -> fmap (rid, ) <$> CL.getTerm code rid - let - allVars :: Set v - allVars = Set.unions - [ UF.allVars uf - , Set.unions [ DD.allVars dd | (_, dd) <- ds1 ] - , Set.unions [ DD.allVars (DD.toDataDecl ed) | (_, ed) <- es1 ] - , Set.unions [ Term.allVars tm | (_, tm) <- bs1 ] - ] - refVar :: Reference.Id -> State (Set v, Map Reference.Id v) v - refVar r = do - m <- snd <$> get - case Map.lookup r m of - Just v -> pure v - Nothing -> do - v <- ABT.freshenS' _1 (Var.refNamed (Reference.DerivedId r)) - _2 %= Map.insert r v - pure v - assignVars :: [(Reference.Id, b)] -> State (Set v, Map Reference.Id v) [(v, (Reference.Id, b))] - assignVars = traverse (\e@(r, _) -> (,e) <$> refVar r) - unref :: Term v a -> State (Set v, Map Reference.Id v) (Term v a) - unref = ABT.visit go where - go t@(Term.Ref' (Reference.DerivedId r)) = - Just (Term.var (ABT.annotation t) <$> refVar r) - go _ = Nothing - unrefb = traverse (\(v, tm) -> (v,) <$> unref tm) - pair :: forall f a b. Applicative f => f a -> f b -> f (a,b) - pair = liftA2 (,) - uf' = flip evalState (allVars, Map.empty) $ do - datas' <- Map.union ds0 . Map.fromList <$> assignVars ds1 - effects' <- Map.union es0 . Map.fromList <$> assignVars es1 - -- bs0 is terms from the input file - bs0' <- unrefb bs0 - ws0' <- traverse unrefb ws0 - -- bs1 is dependency terms - bs1' <- traverse (\(r, tm) -> refVar r `pair` unref tm) bs1 - pure $ UF.UnisonFileId datas' effects' (bs1' ++ bs0') ws0' - pure uf' - getTypeOfTerm :: (Applicative m, Var v, BuiltinAnnotation a) => Codebase m v a -> Reference -> m (Maybe (Type v a)) getTypeOfTerm _c r | debug && trace ("Codebase.getTypeOfTerm " ++ show r) False = undefined @@ -335,7 +204,7 @@ getTypeOfReferent c (Referent.Ref r) = getTypeOfTerm c r getTypeOfReferent c (Referent.Con r cid _) = getTypeOfConstructor c r cid --- The dependents of a builtin type is the set of builtin terms which +-- | The dependents of a builtin type includes the set of builtin terms which -- mention that type. dependents :: Functor m => Codebase m v a -> Reference -> m (Set Reference) dependents c r @@ -369,13 +238,13 @@ isType c r = case r of Reference.Builtin{} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r -class BuiltinAnnotation a where - builtinAnnotation :: a +-- class BuiltinAnnotation a where +-- builtinAnnotation :: a -instance BuiltinAnnotation Parser.Ann where - builtinAnnotation = Parser.Intrinsic +-- instance BuiltinAnnotation Parser.Ann where +-- builtinAnnotation = Parser.Intrinsic --- * Git stuff +-- -- * Git stuff -- | Sync elements as needed from a remote codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; @@ -394,7 +263,7 @@ importRemoteBranch codebase ns mode = runExceptT do lift $ syncFromDirectory codebase cacheDir mode branch ExceptT let h = Branch.headHash branch - err = Left $ GitError.CouldntLoadSyncedBranch h + err = Left . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns h in time "load fresh local branch after sync" $ (getBranchForHash codebase h <&> maybe err Right) <* cleanup @@ -407,4 +276,4 @@ viewRemoteBranch :: m (Either GitError (m (), Branch m)) viewRemoteBranch codebase ns = runExceptT do (cleanup, branch, _) <- ExceptT $ viewRemoteBranch' codebase ns - pure (cleanup, branch) + pure (cleanup, branch) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index f04851ab8a..2dc6d26492 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -7,108 +7,72 @@ module Unison.Codebase.Branch ( -- * Branch types Branch(..) + , BranchDiff(..) , UnwrappedBranch , Branch0(..) - , MergeMode(..) , Raw(..) , Star , Hash , EditHash , pattern Hash - - -- * Branch construction - , empty - , empty0 + -- * Branch construction , branch0 , one + , cons + , uncons + , empty + , empty0 + , discardHistory0 , toCausalRaw , transform - - -- * Branch history - -- ** History queries + -- * Branch tests , isEmpty , isEmpty0 , isOne + , before + , lca + -- * diff + , diff0 + -- * properties , head , headHash - , before - , before' - , findHistoricalHQs - , findHistoricalRefs - , findHistoricalRefs' - , namesDiff - -- ** History updates - , step - , stepEverywhere - , uncons - , merge - , merge' - , merge'' - - -- * Branch children - -- ** Children lenses , children - -- ** Children queries + , deepEdits' , toList0 + -- * step + , stepManyAt + , stepManyAtM + , stepManyAt0 + , stepEverywhere + -- * + , addTermName + , addTypeName + , deleteTermName + , deleteTypeName + , setChildBranch + , replacePatch + , deletePatch + , getMaybePatch + , getPatch + , modifyPatches + -- ** Children queries , getAt , getAt' , getAt0 - -- ** Children updates - , setChildBranch - , stepManyAt - , stepManyAt0 - , stepManyAtM - , modifyAtM , modifyAt - - -- * Branch terms/types/edits - -- ** Term/type/edits lenses + , modifyAtM + -- * Branch terms/types/edits + -- ** Term/type/edits lenses , terms , types , edits -- ** Term/type queries , deepReferents , deepTypeReferences - , toNames0 - -- ** Term/type updates - , addTermName - , addTypeName - , deleteTermName - , deleteTypeName - - - -- * Branch patches - -- ** Patch queries - , deepEdits' - , getPatch - , getMaybePatch - -- ** Patch updates - , replacePatch - , deletePatch - , modifyPatches - - -- * Branch serialization + -- * Branch serialization , cachedRead - , boundedCache , Cache , sync - - -- * Unused - , childrenR - , debugPaths - , editedPatchRemoved - , editsR - , findHistoricalSHs - , fork - , lca - , move - , numHashChars - , printDebugPaths - , removedPatchEdited - , stepAt - , stepAtM - , termsR - , typesR ) where import Unison.Prelude hiding (empty) @@ -140,27 +104,16 @@ import Unison.Hashable ( Hashable ) import qualified Unison.Hashable as H import Unison.Name ( Name(..) ) import qualified Unison.Name as Name -import qualified Unison.Names2 as Names -import qualified Unison.Names3 as Names -import Unison.Names2 ( Names'(Names), Names0 ) import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) -import qualified Unison.Referent as Referent -import qualified Unison.Reference as Reference import qualified U.Util.Cache as Cache import qualified Unison.Util.Relation as R import Unison.Util.Relation ( Relation ) import qualified Unison.Util.Relation4 as R4 -import qualified Unison.Util.List as List import Unison.Util.Map ( unionWithM ) import qualified Unison.Util.Star3 as Star3 -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import qualified Unison.HashQualified as HQ -import Unison.HashQualified (HashQualified) -import qualified Unison.LabeledDependency as LD -import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.Util.List as List -- | A node in the Unison namespace hierarchy -- along with its history. @@ -171,7 +124,6 @@ type UnwrappedBranch m = Causal m Raw (Branch0 m) type Hash = Causal.RawHash Raw type EditHash = Hash.Hash --- Star3 r n Metadata.Type (Metadata.Type, Metadata.Value) type Star r n = Metadata.Star r n -- | A node in the Unison namespace hierarchy. @@ -233,70 +185,6 @@ data Raw = Raw makeLenses ''Branch makeLensesFor [("_edits", "edits")] ''Branch0 -makeLenses ''Raw - -toNames0 :: Branch0 m -> Names0 -toNames0 b = Names (R.swap . deepTerms $ b) - (R.swap . deepTypes $ b) - --- This stops searching for a given ShortHash once it encounters --- any term or type in any Branch0 that satisfies that ShortHash. -findHistoricalSHs - :: Monad m => Set ShortHash -> Branch m -> m (Set ShortHash, Names0) -findHistoricalSHs = findInHistory - (\sh r _n -> sh `SH.isPrefixOf` Referent.toShortHash r) - (\sh r _n -> sh `SH.isPrefixOf` Reference.toShortHash r) - --- This stops searching for a given HashQualified once it encounters --- any term or type in any Branch0 that satisfies that HashQualified. -findHistoricalHQs :: Monad m - => Set (HashQualified Name) - -> Branch m - -> m (Set (HashQualified Name), Names0) -findHistoricalHQs = findInHistory - (\hq r n -> HQ.matchesNamedReferent n r hq) - (\hq r n -> HQ.matchesNamedReference n r hq) - -findHistoricalRefs :: Monad m => Set LabeledDependency -> Branch m - -> m (Set LabeledDependency, Names0) -findHistoricalRefs = findInHistory - (\query r _n -> LD.fold (const False) (==r) query) - (\query r _n -> LD.fold (==r) (const False) query) - -findHistoricalRefs' :: Monad m => Set Reference -> Branch m - -> m (Set Reference, Names0) -findHistoricalRefs' = findInHistory - (\queryRef r _n -> r == Referent.Ref queryRef) - (\queryRef r _n -> r == queryRef) - -findInHistory :: forall m q. (Monad m, Ord q) - => (q -> Referent -> Name -> Bool) - -> (q -> Reference -> Name -> Bool) - -> Set q -> Branch m -> m (Set q, Names0) -findInHistory termMatches typeMatches queries b = - (Causal.foldHistoryUntil f (queries, mempty) . _history) b <&> \case - -- could do something more sophisticated here later to report that some SH - -- couldn't be found anywhere in the history. but for now, I assume that - -- the normal thing will happen when it doesn't show up in the namespace. - Causal.Satisfied (_, names) -> (mempty, names) - Causal.Unsatisfied (missing, names) -> (missing, names) - where - -- in order to not favor terms over types, we iterate through the ShortHashes, - -- for each `remainingQueries`, if we find a matching Referent or Reference, - -- we remove `q` from the accumulated `remainingQueries`, and add the Ref* to - -- the accumulated `names0`. - f acc@(remainingQueries, _) b0 = (acc', null remainingQueries') - where - acc'@(remainingQueries', _) = foldl' findQ acc remainingQueries - findQ :: (Set q, Names0) -> q -> (Set q, Names0) - findQ acc sh = - foldl' (doType sh) (foldl' (doTerm sh) acc - (R.toList $ deepTerms b0)) - (R.toList $ deepTypes b0) - doTerm q acc@(remainingSHs, names0) (r, n) = if termMatches q r n - then (Set.delete q remainingSHs, Names.addTerm n r names0) else acc - doType q acc@(remainingSHs, names0) (r, n) = if typeMatches q r n - then (Set.delete q remainingSHs, Names.addType n r names0) else acc deepReferents :: Branch0 m -> Set Referent deepReferents = R.dom . deepTerms @@ -361,6 +249,7 @@ head (Branch c) = Causal.head c headHash :: Branch m -> Hash headHash (Branch c) = Causal.currentHash c +-- | a version of `deepEdits` that returns the `m Patch` as well. deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) deepEdits' b = go id b where -- can change this to an actual prefix once Name is a [NameSegment] @@ -372,127 +261,42 @@ deepEdits' b = go id b where f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) -data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) - -merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) -merge = merge' RegularMerge - -- Discards the history of a Branch0's children, recursively discardHistory0 :: Applicative m => Branch0 m -> Branch0 m discardHistory0 = over children (fmap tweak) where tweak b = cons (discardHistory0 (head b)) empty -merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) -merge' = merge'' lca - -merge'' :: forall m . Monad m - => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator - -> MergeMode - -> Branch m - -> Branch m - -> m (Branch m) -merge'' _ _ b1 b2 | isEmpty b1 = pure b2 -merge'' _ mode b1 b2 | isEmpty b2 = case mode of - RegularMerge -> pure b1 - SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 -merge'' lca mode (Branch x) (Branch y) = - Branch <$> case mode of - RegularMerge -> Causal.threeWayMerge' lca' combine x y - SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y - where - lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) - combine Nothing l r = merge0 lca mode l r - combine (Just ca) l r = do - dl <- diff0 ca l - dr <- diff0 ca r - head0 <- apply ca (dl <> dr) - children <- Map.mergeA - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.zipWithAMatched $ const (merge'' lca mode)) - (_children l) (_children r) - pure $ branch0 (_terms head0) (_types head0) children (_edits head0) - - combineMissing ca k cur = - case Map.lookup k (_children ca) of - Nothing -> pure $ Just cur - Just old -> do - nw <- merge'' lca mode (cons empty0 old) cur - if isEmpty0 $ head nw - then pure Nothing - else pure $ Just nw - - apply :: Branch0 m -> BranchDiff -> m (Branch0 m) - apply b0 BranchDiff {..} = do - patches <- sequenceA - $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches - let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) - makePatch Patch.PatchDiff {..} = - let p = Patch.Patch _addedTermEdits _addedTypeEdits - in (H.accumulate' p, pure p) - pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) - (Star3.difference (_types b0) removedTypes <> addedTypes) - (_children b0) - (patches <> newPatches) - patchMerge mhp Patch.PatchDiff {..} = Just $ do - (_, mp) <- mhp - p <- mp - let np = Patch.Patch - { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits - <> _addedTermEdits - , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits - <> _addedTypeEdits - } - pure (H.accumulate' np, pure np) - --- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- It's defined as: lca b1 b2 == Just b1 -before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) - -> Branch m -> Branch m -> m Bool -before' lca (Branch x) (Branch y) = Causal.before' lca' x y - where - lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + +-- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` +-- -- It's defined as: lca b1 b2 == Just b1 +-- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) +-- -> Branch m -> Branch m -> m Bool +-- before' lca (Branch x) (Branch y) = Causal.before' lca' x y +-- where +-- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) -- `before b1 b2` is true if `b2` incorporates all of `b1` before :: Monad m => Branch m -> Branch m -> m Bool before (Branch b1) (Branch b2) = Causal.before b1 b2 -merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) - -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) -merge0 lca mode b1 b2 = do - c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) - e3 <- unionWithM g (_edits b1) (_edits b2) - pure $ branch0 (_terms b1 <> _terms b2) - (_types b1 <> _types b2) - c3 - e3 - where - g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) - g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) - g (_, m1) (_, m2) = do - e1 <- m1 - e2 <- m2 - let e3 = e1 <> e2 - pure (H.accumulate' e3, pure e3) - pattern Hash h = Causal.RawHash h +-- | what does this do? —AI toList0 :: Branch0 m -> [(Path, Branch0 m)] toList0 = go Path.empty where go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> go (Path.snoc p seg) (head cb) )) -printDebugPaths :: Branch m -> String -printDebugPaths = unlines . map show . Set.toList . debugPaths +-- printDebugPaths :: Branch m -> String +-- printDebugPaths = unlines . map show . Set.toList . debugPaths -debugPaths :: Branch m -> Set (Path, Hash) -debugPaths = go Path.empty where - go p b = Set.insert (p, headHash b) . Set.unions $ - [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] +-- debugPaths :: Branch m -> Set (Path, Hash) +-- debugPaths = go Path.empty where +-- go p b = Set.insert (p, headHash b) . Set.unions $ +-- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] -data Target = TargetType | TargetTerm | TargetBranch - deriving (Eq, Ord, Show) +-- data Target = TargetType | TargetTerm | TargetBranch +-- deriving (Eq, Ord, Show) instance Eq (Branch0 m) where a == b = view terms a == view terms b @@ -500,21 +304,21 @@ instance Eq (Branch0 m) where && view children a == view children b && (fmap fst . view edits) a == (fmap fst . view edits) b -data ForkFailure = SrcNotFound | DestExists +-- data ForkFailure = SrcNotFound | DestExists --- consider delegating to Names.numHashChars when ready to implement? --- are those enough? --- could move this to a read-only field in Branch0 --- could move a Names0 to a read-only field in Branch0 until it gets too big -numHashChars :: Branch m -> Int -numHashChars _b = 3 +-- -- consider delegating to Names.numHashChars when ready to implement? +-- -- are those enough? +-- -- could move this to a read-only field in Branch0 +-- -- could move a Names0 to a read-only field in Branch0 until it gets too big +-- numHashChars :: Branch m -> Int +-- numHashChars _b = 3 -- This type is a little ugly, so we wrap it up with a nice type alias for -- use outside this module. type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) -boundedCache :: MonadIO m => Word -> m (Cache m2) -boundedCache = Cache.semispaceCache +-- boundedCache :: MonadIO m => Word -> m (Cache m2) +-- boundedCache = Cache.semispaceCache -- Can use `Cache.nullCache` to disable caching if needed cachedRead :: forall m . MonadIO m @@ -596,51 +400,51 @@ toCausalRaw = \case Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) --- copy a path to another path -fork - :: Applicative m - => Path - -> Path - -> Branch m - -> Either ForkFailure (Branch m) -fork src dest root = case getAt src root of - Nothing -> Left SrcNotFound - Just src' -> case setIfNotExists dest src' root of - Nothing -> Left DestExists - Just root' -> Right root' - --- Move the node at src to dest. --- It's okay if `dest` is inside `src`, just create empty levels. --- Try not to `step` more than once at each node. -move :: Applicative m - => Path - -> Path - -> Branch m - -> Either ForkFailure (Branch m) -move src dest root = case getAt src root of - Nothing -> Left SrcNotFound - Just src' -> - -- make sure dest doesn't already exist - case getAt dest root of - Just _destExists -> Left DestExists - Nothing -> - -- find and update common ancestor of `src` and `dest`: - Right $ modifyAt ancestor go root - where - (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest - go = deleteAt relSrc . setAt relDest src' - -setIfNotExists - :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) -setIfNotExists dest b root = case getAt dest root of - Just _destExists -> Nothing - Nothing -> Just $ setAt dest b root - -setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m -setAt path b = modifyAt path (const b) - -deleteAt :: Applicative m => Path -> Branch m -> Branch m -deleteAt path = setAt path empty +-- -- copy a path to another path +-- fork +-- :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- fork src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> case setIfNotExists dest src' root of +-- Nothing -> Left DestExists +-- Just root' -> Right root' + +-- -- Move the node at src to dest. +-- -- It's okay if `dest` is inside `src`, just create empty levels. +-- -- Try not to `step` more than once at each node. +-- move :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- move src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> +-- -- make sure dest doesn't already exist +-- case getAt dest root of +-- Just _destExists -> Left DestExists +-- Nothing -> +-- -- find and update common ancestor of `src` and `dest`: +-- Right $ modifyAt ancestor go root +-- where +-- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest +-- go = deleteAt relSrc . setAt relDest src' + +-- setIfNotExists +-- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) +-- setIfNotExists dest b root = case getAt dest root of +-- Just _destExists -> Nothing +-- Nothing -> Just $ setAt dest b root + +-- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m +-- setAt path b = modifyAt path (const b) + +-- deleteAt :: Applicative m => Path -> Branch m -> Branch m +-- deleteAt path = setAt path empty -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` getAt :: Path @@ -874,8 +678,8 @@ deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) = over types (Star3.deletePrimaryD1 (r,n)) b deleteTypeName _ _ b = b -namesDiff :: Branch m -> Branch m -> Names.Diff -namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) +-- namesDiff :: Branch m -> Branch m -> Names.Diff +-- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b @@ -912,29 +716,29 @@ transform f b = case _history b of -> Causal m Raw (Branch0 n) transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) -data BranchAttentions = BranchAttentions - { -- Patches that were edited on the right but entirely removed on the left. - removedPatchEdited :: [Name] - -- Patches that were edited on the left but entirely removed on the right. - , editedPatchRemoved :: [Name] - } - -instance Semigroup BranchAttentions where - BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 - = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - -instance Monoid BranchAttentions where - mempty = BranchAttentions [] [] - mappend = (<>) - -data RefCollisions = - RefCollisions { termCollisions :: Relation Name Name - , typeCollisions :: Relation Name Name - } deriving (Eq, Show) - -instance Semigroup RefCollisions where - (<>) = mappend -instance Monoid RefCollisions where - mempty = RefCollisions mempty mempty - mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) - (typeCollisions r1 <> typeCollisions r2) +-- data BranchAttentions = BranchAttentions +-- { -- Patches that were edited on the right but entirely removed on the left. +-- removedPatchEdited :: [Name] +-- -- Patches that were edited on the left but entirely removed on the right. +-- , editedPatchRemoved :: [Name] +-- } + +-- instance Semigroup BranchAttentions where +-- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 +-- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) + +-- instance Monoid BranchAttentions where +-- mempty = BranchAttentions [] [] +-- mappend = (<>) + +-- data RefCollisions = +-- RefCollisions { termCollisions :: Relation Name Name +-- , typeCollisions :: Relation Name Name +-- } deriving (Eq, Show) + +-- instance Semigroup RefCollisions where +-- (<>) = mappend +-- instance Monoid RefCollisions where +-- mempty = RefCollisions mempty mempty +-- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) +-- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs new file mode 100644 index 0000000000..12e4c08e7a --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Unison.Codebase.Branch.Merge + ( MergeMode(..) + , merge'' + ) where + +import Unison.Prelude hiding (empty) +import Unison.Codebase.Branch + +import Prelude hiding (head,read,subtract) + +import Control.Lens hiding ( children, cons, transform, uncons ) +import qualified Control.Monad.State as State +import Control.Monad.State ( StateT ) +import Data.Bifunctor ( second ) +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map +import qualified Data.Set as Set +import qualified Unison.Codebase.Patch as Patch +import Unison.Codebase.Patch ( Patch ) +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.Causal ( Causal + , pattern RawOne + , pattern RawCons + , pattern RawMerge + ) +import Unison.Codebase.Path ( Path(..) ) +import qualified Unison.Codebase.Path as Path +import Unison.NameSegment ( NameSegment ) +import qualified Unison.NameSegment as NameSegment +import qualified Unison.Codebase.Metadata as Metadata +import qualified Unison.Hash as Hash +import Unison.Hashable ( Hashable ) +import qualified Unison.Hashable as H +import Unison.Name ( Name(..) ) +import qualified Unison.Name as Name +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) + +import qualified U.Util.Cache as Cache +import qualified Unison.Util.Relation as R +import Unison.Util.Relation ( Relation ) +import qualified Unison.Util.Relation4 as R4 +import Unison.Util.Map ( unionWithM ) +import qualified Unison.Util.Star3 as Star3 + +-- -- | 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) + +-- type Hash = Causal.RawHash Raw +-- type EditHash = Hash.Hash + +-- 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` +-- , deepTerms :: Relation Referent Name +-- , deepTypes :: Relation Reference Name +-- , deepTermMetadata :: Metadata.R4 Referent Name +-- , deepTypeMetadata :: Metadata.R4 Reference Name +-- , deepPaths :: Set Path +-- , deepEdits :: Map Name EditHash +-- } + +-- -- Represents a shallow diff of a Branch0. +-- -- Each of these `Star`s contain metadata as well, so an entry in +-- -- `added` or `removed` could be an update to the metadata. +-- data BranchDiff = BranchDiff +-- { addedTerms :: Star Referent NameSegment +-- , removedTerms :: Star Referent NameSegment +-- , addedTypes :: Star Reference NameSegment +-- , removedTypes :: Star Reference NameSegment +-- , changedPatches :: Map NameSegment Patch.PatchDiff +-- } deriving (Eq, Ord, Show) + +-- instance Semigroup BranchDiff where +-- left <> right = BranchDiff +-- { addedTerms = addedTerms left <> addedTerms right +-- , removedTerms = removedTerms left <> removedTerms right +-- , addedTypes = addedTypes left <> addedTypes right +-- , removedTypes = removedTypes left <> removedTypes right +-- , changedPatches = +-- Map.unionWith (<>) (changedPatches left) (changedPatches right) +-- } + +-- instance Monoid BranchDiff where +-- mappend = (<>) +-- mempty = BranchDiff mempty mempty mempty mempty mempty + +-- -- The raw Branch +-- data Raw = Raw +-- { _termsR :: Star Referent NameSegment +-- , _typesR :: Star Reference NameSegment +-- , _childrenR :: Map NameSegment Hash +-- , _editsR :: Map NameSegment EditHash +-- } + +-- makeLenses ''Branch +-- makeLensesFor [("_edits", "edits")] ''Branch0 + +-- terms :: Lens' (Branch0 m) (Star Referent NameSegment) +-- terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) + +-- types :: Lens' (Branch0 m) (Star Reference NameSegment) +-- types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) + +-- children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) +-- children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) + +-- -- creates a Branch0 from the primary fields and derives the others. +-- branch0 :: Metadata.Star Referent NameSegment +-- -> Metadata.Star Reference NameSegment +-- -> Map NameSegment (Branch m) +-- -> Map NameSegment (EditHash, m Patch) +-- -> Branch0 m +-- branch0 terms types children edits = +-- Branch0 terms types children edits +-- deepTerms' deepTypes' +-- deepTermMetadata' deepTypeMetadata' +-- deepPaths' deepEdits' +-- where +-- nameSegToName = Name.unsafeFromText . NameSegment.toText +-- deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms +-- <> foldMap go (Map.toList children) +-- where +-- go (nameSegToName -> n, b) = +-- R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic +-- deepTypes' = (R.mapRan nameSegToName . Star3.d1) types +-- <> foldMap go (Map.toList children) +-- where +-- go (nameSegToName -> n, b) = +-- R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic +-- deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) +-- <> foldMap go (Map.toList children) +-- where +-- go (nameSegToName -> n, b) = +-- R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) +-- deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) +-- <> foldMap go (Map.toList children) +-- where +-- go (nameSegToName -> n, b) = +-- R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) +-- deepPaths' = Set.map Path.singleton (Map.keysSet children) +-- <> foldMap go (Map.toList children) +-- where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) +-- deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) +-- <> foldMap go (Map.toList children) +-- where +-- go (nameSeg, b) = +-- Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b + +-- head :: Branch m -> Branch0 m +-- head (Branch c) = Causal.head c + +-- headHash :: Branch m -> Hash +-- headHash (Branch c) = Causal.currentHash c + +-- -- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) +-- -- deepEdits' b = go id b where +-- -- -- can change this to an actual prefix once Name is a [NameSegment] +-- -- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) +-- -- go addPrefix Branch0{..} = +-- -- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits +-- -- <> foldMap f (Map.toList _children) +-- -- where +-- -- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) +-- -- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) + +data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) + +merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) +merge = merge' RegularMerge + +-- -- Discards the history of a Branch0's children, recursively +-- discardHistory0 :: Applicative m => Branch0 m -> Branch0 m +-- discardHistory0 = over children (fmap tweak) where +-- tweak b = cons (discardHistory0 (head b)) empty + +merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) +merge' = merge'' lca + +merge'' :: forall m . Monad m + => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator + -> MergeMode + -> Branch m + -> Branch m + -> m (Branch m) +merge'' _ _ b1 b2 | isEmpty b1 = pure b2 +merge'' _ mode b1 b2 | isEmpty b2 = case mode of + RegularMerge -> pure b1 + SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 +merge'' lca mode (Branch x) (Branch y) = + Branch <$> case mode of + RegularMerge -> Causal.threeWayMerge' lca' combine x y + SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y + where + lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) + combine Nothing l r = merge0 lca mode l r + combine (Just ca) l r = do + dl <- diff0 ca l + dr <- diff0 ca r + head0 <- apply ca (dl <> dr) + children <- Map.mergeA + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.zipWithAMatched $ const (merge'' lca mode)) + (_children l) (_children r) + pure $ branch0 (_terms head0) (_types head0) children (_edits head0) + + combineMissing ca k cur = + case Map.lookup k (_children ca) of + Nothing -> pure $ Just cur + Just old -> do + nw <- merge'' lca mode (cons empty0 old) cur + if isEmpty0 $ head nw + then pure Nothing + else pure $ Just nw + + apply :: Branch0 m -> BranchDiff -> m (Branch0 m) + apply b0 BranchDiff {..} = do + patches <- sequenceA + $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches + let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) + makePatch Patch.PatchDiff {..} = + let p = Patch.Patch _addedTermEdits _addedTypeEdits + in (H.accumulate' p, pure p) + pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) + (Star3.difference (_types b0) removedTypes <> addedTypes) + (_children b0) + (patches <> newPatches) + patchMerge mhp Patch.PatchDiff {..} = Just $ do + (_, mp) <- mhp + p <- mp + let np = Patch.Patch + { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits + <> _addedTermEdits + , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits + <> _addedTypeEdits + } + pure (H.accumulate' np, pure np) + +-- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` +-- -- It's defined as: lca b1 b2 == Just b1 +-- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) +-- -> Branch m -> Branch m -> m Bool +-- before' lca (Branch x) (Branch y) = Causal.before' lca' x y +-- where +-- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + +-- `before b1 b2` is true if `b2` incorporates all of `b1` +before :: Monad m => Branch m -> Branch m -> m Bool +before (Branch b1) (Branch b2) = Causal.before b1 b2 + +merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) + -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) +merge0 lca mode b1 b2 = do + c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) + e3 <- unionWithM g (_edits b1) (_edits b2) + pure $ branch0 (_terms b1 <> _terms b2) + (_types b1 <> _types b2) + c3 + e3 + where + g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) + g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) + g (_, m1) (_, m2) = do + e1 <- m1 + e2 <- m2 + let e3 = e1 <> e2 + pure (H.accumulate' e3, pure e3) + +-- pattern Hash h = Causal.RawHash h + +-- -- toList0 :: Branch0 m -> [(Path, Branch0 m)] +-- -- toList0 = go Path.empty where +-- -- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> +-- -- go (Path.snoc p seg) (head cb) )) + +-- -- printDebugPaths :: Branch m -> String +-- -- printDebugPaths = unlines . map show . Set.toList . debugPaths + +-- -- debugPaths :: Branch m -> Set (Path, Hash) +-- -- debugPaths = go Path.empty where +-- -- go p b = Set.insert (p, headHash b) . Set.unions $ +-- -- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] + +-- -- data Target = TargetType | TargetTerm | TargetBranch +-- -- deriving (Eq, Ord, Show) + +-- instance Eq (Branch0 m) where +-- a == b = view terms a == view terms b +-- && view types a == view types b +-- && view children a == view children b +-- && (fmap fst . view edits) a == (fmap fst . view edits) b + +-- -- data ForkFailure = SrcNotFound | DestExists + +-- -- -- consider delegating to Names.numHashChars when ready to implement? +-- -- -- are those enough? +-- -- -- could move this to a read-only field in Branch0 +-- -- -- could move a Names0 to a read-only field in Branch0 until it gets too big +-- -- numHashChars :: Branch m -> Int +-- -- numHashChars _b = 3 + +-- -- This type is a little ugly, so we wrap it up with a nice type alias for +-- -- use outside this module. +-- type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) + +-- -- boundedCache :: MonadIO m => Word -> m (Cache m2) +-- -- boundedCache = Cache.semispaceCache + +-- -- Can use `Cache.nullCache` to disable caching if needed +-- cachedRead :: forall m . MonadIO m +-- => Cache m +-- -> Causal.Deserialize m Raw Raw +-- -> (EditHash -> m Patch) +-- -> Hash +-- -> m (Branch m) +-- cachedRead cache deserializeRaw deserializeEdits h = +-- Branch <$> Causal.cachedRead cache d h +-- where +-- fromRaw :: Raw -> m (Branch0 m) +-- fromRaw Raw {..} = do +-- children <- traverse go _childrenR +-- edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash +-- pure $ branch0 _termsR _typesR children edits +-- go = cachedRead cache deserializeRaw deserializeEdits +-- d :: Causal.Deserialize m Raw (Branch0 m) +-- d h = deserializeRaw h >>= \case +-- RawOne raw -> RawOne <$> fromRaw raw +-- RawCons raw h -> flip RawCons h <$> fromRaw raw +-- RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw + +-- sync +-- :: Monad m +-- => (Hash -> m Bool) +-- -> Causal.Serialize m Raw Raw +-- -> (EditHash -> m Patch -> m ()) +-- -> Branch m +-- -> m () +-- sync exists serializeRaw serializeEdits b = do +-- _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty +-- -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." +-- pure () + +-- -- serialize a `Branch m` indexed by the hash of its corresponding Raw +-- sync' +-- :: forall m +-- . Monad m +-- => (Hash -> m Bool) +-- -> Causal.Serialize m Raw Raw +-- -> (EditHash -> m Patch -> m ()) +-- -> Branch m +-- -> StateT (Set Hash) m () +-- sync' exists serializeRaw serializeEdits b = Causal.sync exists +-- serialize0 +-- (view history b) +-- where +-- serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) +-- serialize0 h b0 = case b0 of +-- RawOne b0 -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawOne (toRaw b0) +-- RawCons b0 ht -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawCons (toRaw b0) ht +-- RawMerge b0 hs -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawMerge (toRaw b0) hs +-- where +-- writeB0 :: Branch0 m -> StateT (Set Hash) m () +-- writeB0 b0 = do +-- for_ (view children b0) $ \c -> do +-- queued <- State.get +-- when (Set.notMember (headHash c) queued) $ +-- sync' exists serializeRaw serializeEdits c +-- for_ (view edits b0) (lift . uncurry serializeEdits) + +-- -- this has to serialize the branch0 and its descendants in the tree, +-- -- and then serialize the rest of the history of the branch as well + +-- toRaw :: Branch0 m -> Raw +-- toRaw Branch0 {..} = +-- Raw _terms _types (headHash <$> _children) (fst <$> _edits) + +-- toCausalRaw :: Branch m -> Causal.Raw Raw Raw +-- toCausalRaw = \case +-- Branch (Causal.One _h e) -> RawOne (toRaw e) +-- Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht +-- Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) + +-- -- -- copy a path to another path +-- -- fork +-- -- :: Applicative m +-- -- => Path +-- -- -> Path +-- -- -> Branch m +-- -- -> Either ForkFailure (Branch m) +-- -- fork src dest root = case getAt src root of +-- -- Nothing -> Left SrcNotFound +-- -- Just src' -> case setIfNotExists dest src' root of +-- -- Nothing -> Left DestExists +-- -- Just root' -> Right root' + +-- -- -- Move the node at src to dest. +-- -- -- It's okay if `dest` is inside `src`, just create empty levels. +-- -- -- Try not to `step` more than once at each node. +-- -- move :: Applicative m +-- -- => Path +-- -- -> Path +-- -- -> Branch m +-- -- -> Either ForkFailure (Branch m) +-- -- move src dest root = case getAt src root of +-- -- Nothing -> Left SrcNotFound +-- -- Just src' -> +-- -- -- make sure dest doesn't already exist +-- -- case getAt dest root of +-- -- Just _destExists -> Left DestExists +-- -- Nothing -> +-- -- -- find and update common ancestor of `src` and `dest`: +-- -- Right $ modifyAt ancestor go root +-- -- where +-- -- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest +-- -- go = deleteAt relSrc . setAt relDest src' + +-- -- setIfNotExists +-- -- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) +-- -- setIfNotExists dest b root = case getAt dest root of +-- -- Just _destExists -> Nothing +-- -- Nothing -> Just $ setAt dest b root + +-- -- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m +-- -- setAt path b = modifyAt path (const b) + +-- -- deleteAt :: Applicative m => Path -> Branch m -> Branch m +-- -- deleteAt path = setAt path empty + +-- -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` +-- getAt :: Path +-- -> Branch m +-- -> Maybe (Branch m) +-- getAt path root = case Path.uncons path of +-- Nothing -> if isEmpty root then Nothing else Just root +-- Just (seg, path) -> case Map.lookup seg (_children $ head root) of +-- Just b -> getAt path b +-- Nothing -> Nothing + +-- getAt' :: Path -> Branch m -> Branch m +-- getAt' p b = fromMaybe empty $ getAt p b + +-- -- getAt0 :: Path -> Branch0 m -> Branch0 m +-- -- getAt0 p b = case Path.uncons p of +-- -- Nothing -> b +-- -- Just (seg, path) -> case Map.lookup seg (_children b) of +-- -- Just c -> getAt0 path (head c) +-- -- Nothing -> empty0 + +-- empty :: Branch m +-- empty = Branch $ Causal.one empty0 + +-- -- one :: Branch0 m -> Branch m +-- -- one = Branch . Causal.one + +-- empty0 :: Branch0 m +-- empty0 = +-- Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty + +-- isEmpty0 :: Branch0 m -> Bool +-- isEmpty0 = (== empty0) + +-- isEmpty :: Branch m -> Bool +-- isEmpty = (== empty) + +-- step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m +-- step f = \case +-- Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) +-- b -> over history (Causal.stepDistinct f) b + +-- -- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- -- stepM f = \case +-- -- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 +-- -- b -> mapMOf history (Causal.stepDistinctM f) b + +-- cons :: Applicative m => Branch0 m -> Branch m -> Branch m +-- cons = step . const + +-- -- isOne :: Branch m -> Bool +-- -- isOne (Branch Causal.One{}) = True +-- -- isOne _ = False + +-- -- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) +-- -- uncons (Branch b) = go <$> Causal.uncons b where +-- -- go = over (_Just . _2) Branch + +-- -- -- Modify the branch0 at the head of at `path` with `f`, +-- -- -- after creating it if necessary. Preserves history. +-- -- stepAt :: forall m. Applicative m +-- -- => Path +-- -- -> (Branch0 m -> Branch0 m) +-- -- -> Branch m -> Branch m +-- -- stepAt p f = modifyAt p g where +-- -- g :: Branch m -> Branch m +-- -- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b + +-- -- stepManyAt :: (Monad m, Foldable f) +-- -- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m +-- -- stepManyAt actions = step (stepManyAt0 actions) + +-- -- -- Modify the branch0 at the head of at `path` with `f`, +-- -- -- after creating it if necessary. Preserves history. +-- -- stepAtM :: forall n m. (Functor n, Applicative m) +-- -- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- -- stepAtM p f = modifyAtM p g where +-- -- g :: Branch m -> n (Branch m) +-- -- g (Branch b) = do +-- -- b0' <- f (Causal.head b) +-- -- pure $ Branch . Causal.consDistinct b0' $ b + +-- -- stepManyAtM :: (Monad m, Monad n, Foldable f) +-- -- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- -- stepManyAtM actions = stepM (stepManyAt0M actions) + +-- -- -- starting at the leaves, apply `f` to every level of the branch. +-- -- stepEverywhere +-- -- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) +-- -- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) +-- -- where children = fmap (step $ stepEverywhere f) _children + +-- -- -- Creates a function to fix up the children field._1 +-- -- -- If the action emptied a child, then remove the mapping, +-- -- -- otherwise update it. +-- -- -- Todo: Fix this in hashing & serialization instead of here? +-- -- getChildBranch :: NameSegment -> Branch0 m -> Branch m +-- -- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) + +-- -- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m +-- -- setChildBranch seg b = over children (updateChildren seg b) + +-- -- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch +-- -- getPatch seg b = case Map.lookup seg (_edits b) of +-- -- Nothing -> pure Patch.empty +-- -- Just (_, p) -> p + +-- -- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) +-- -- getMaybePatch seg b = case Map.lookup seg (_edits b) of +-- -- Nothing -> pure Nothing +-- -- Just (_, p) -> Just <$> p + +-- -- modifyPatches +-- -- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) +-- -- modifyPatches seg f = mapMOf edits update +-- -- where +-- -- update m = do +-- -- p' <- case Map.lookup seg m of +-- -- Nothing -> pure $ f Patch.empty +-- -- Just (_, p) -> f <$> p +-- -- let h = H.accumulate' p' +-- -- pure $ Map.insert seg (h, pure p') m + +-- -- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m +-- -- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) + +-- -- deletePatch :: NameSegment -> Branch0 m -> Branch0 m +-- -- deletePatch n = over edits (Map.delete n) + +-- -- updateChildren ::NameSegment +-- -- -> Branch m +-- -- -> Map NameSegment (Branch m) +-- -- -> Map NameSegment (Branch m) +-- -- updateChildren seg updatedChild = +-- -- if isEmpty updatedChild +-- -- then Map.delete seg +-- -- else Map.insert seg updatedChild + +-- -- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- -- Because it's a `Branch`, it overwrites the history at `path`. +-- -- modifyAt :: Applicative m +-- -- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m +-- -- modifyAt path f = runIdentity . modifyAtM path (pure . f) + +-- -- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- -- Because it's a `Branch`, it overwrites the history at `path`. +-- -- modifyAtM +-- -- :: forall n m +-- -- . Functor n +-- -- => Applicative m -- because `Causal.cons` uses `pure` +-- -- => Path +-- -- -> (Branch m -> n (Branch m)) +-- -- -> Branch m +-- -- -> n (Branch m) +-- -- modifyAtM path f b = case Path.uncons path of +-- -- Nothing -> f b +-- -- Just (seg, path) -> do -- Functor +-- -- let child = getChildBranch seg (head b) +-- -- child' <- modifyAtM path f child +-- -- -- step the branch by updating its children according to fixup +-- -- pure $ step (setChildBranch seg child') b + +-- -- -- stepManyAt0 consolidates several changes into a single step +-- -- stepManyAt0 :: forall f m . (Monad m, Foldable f) +-- -- => f (Path, Branch0 m -> Branch0 m) +-- -- -> Branch0 m -> Branch0 m +-- -- stepManyAt0 actions = +-- -- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] + +-- -- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) +-- -- => f (Path, Branch0 m -> n (Branch0 m)) +-- -- -> Branch0 m -> n (Branch0 m) +-- -- stepManyAt0M actions b = go (toList actions) b where +-- -- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) +-- -- go actions b = let +-- -- -- combines the functions that apply to this level of the tree +-- -- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] + +-- -- -- groups the actions based on the child they apply to +-- -- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] +-- -- childActions = +-- -- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] + +-- -- -- alters the children of `b` based on the `childActions` map +-- -- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) +-- -- stepChildren children0 = foldM g children0 $ Map.toList childActions +-- -- where +-- -- g children (seg, actions) = do +-- -- -- Recursively applies the relevant actions to the child branch +-- -- -- The `findWithDefault` is important - it allows the stepManyAt +-- -- -- to create new children at paths that don't previously exist. +-- -- child <- stepM (go actions) (Map.findWithDefault empty seg children0) +-- -- pure $ updateChildren seg child children +-- -- in do +-- -- c2 <- stepChildren (view children b) +-- -- currentAction (set children c2 b) + +-- instance Hashable (Branch0 m) where +-- tokens b = +-- [ H.accumulateToken (_terms b) +-- , H.accumulateToken (_types b) +-- , H.accumulateToken (headHash <$> _children b) +-- , H.accumulateToken (fst <$> _edits b) +-- ] + +-- -- -- getLocalBranch :: Hash -> IO Branch +-- -- -- getGithubBranch :: RemotePath -> IO Branch +-- -- -- getLocalEdit :: GUID -> IO Patch + +-- -- -- todo: consider inlining these into Actions2 +-- -- addTermName +-- -- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- -- addTermName r new md = +-- -- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- -- addTypeName +-- -- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- -- addTypeName r new md = +-- -- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- -- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m +-- -- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m + +-- -- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m +-- -- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) +-- -- = over terms (Star3.deletePrimaryD1 (r,n)) b +-- -- deleteTermName _ _ b = b + +-- -- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m +-- -- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) +-- -- = over types (Star3.deletePrimaryD1 (r,n)) b +-- -- deleteTypeName _ _ b = b + +-- -- namesDiff :: Branch m -> Branch m -> Names.Diff +-- -- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) + +-- lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) +-- lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b + +-- diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff +-- diff0 old new = do +-- newEdits <- sequenceA $ snd <$> _edits new +-- oldEdits <- sequenceA $ snd <$> _edits old +-- let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) +-- (Map.mapMissing $ \_ p -> Patch.diff mempty p) +-- (Map.zipWithMatched (const Patch.diff)) +-- newEdits +-- oldEdits +-- pure $ BranchDiff +-- { addedTerms = Star3.difference (_terms new) (_terms old) +-- , removedTerms = Star3.difference (_terms old) (_terms new) +-- , addedTypes = Star3.difference (_types new) (_types old) +-- , removedTypes = Star3.difference (_types old) (_types new) +-- , changedPatches = diffEdits +-- } + +-- transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n +-- transform f b = case _history b of +-- causal -> Branch . Causal.transform f $ transformB0s f causal +-- where +-- transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n +-- transformB0 f b = +-- b { _children = transform f <$> _children b +-- , _edits = second f <$> _edits b +-- } + +-- transformB0s :: Functor m => (forall a . m a -> n a) +-- -> Causal m Raw (Branch0 m) +-- -> Causal m Raw (Branch0 n) +-- transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) + +-- -- data BranchAttentions = BranchAttentions +-- -- { -- Patches that were edited on the right but entirely removed on the left. +-- -- removedPatchEdited :: [Name] +-- -- -- Patches that were edited on the left but entirely removed on the right. +-- -- , editedPatchRemoved :: [Name] +-- -- } + +-- -- instance Semigroup BranchAttentions where +-- -- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 +-- -- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) + +-- -- instance Monoid BranchAttentions where +-- -- mempty = BranchAttentions [] [] +-- -- mappend = (<>) + +-- -- data RefCollisions = +-- -- RefCollisions { termCollisions :: Relation Name Name +-- -- , typeCollisions :: Relation Name Name +-- -- } deriving (Eq, Show) + +-- -- instance Semigroup RefCollisions where +-- -- (<>) = mappend +-- -- instance Monoid RefCollisions where +-- -- mempty = RefCollisions mempty mempty +-- -- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) +-- -- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs new file mode 100644 index 0000000000..b3c8e88e01 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs @@ -0,0 +1,771 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Branch.Names + ( findHistoricalHQs, + findHistoricalRefs, + findHistoricalRefs', + namesDiff, + toNames0, + ) +where + +import Unison.Prelude hiding (empty) + +import Prelude hiding (head,read,subtract) + +import Control.Lens hiding ( children, cons, transform, uncons ) +import qualified Control.Monad.State as State +import Control.Monad.State ( StateT ) +import Data.Bifunctor ( second ) +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map +import qualified Data.Set as Set +import qualified Unison.Codebase.Patch as Patch +import Unison.Codebase.Patch ( Patch ) +import qualified Unison.Codebase.Causal as Causal +import qualified Unison.Codebase.Causal.FoldHistory as Causal +import Unison.Codebase.Causal ( Causal + , pattern RawOne + , pattern RawCons + , pattern RawMerge + ) +import Unison.Codebase.Path ( Path(..) ) +import qualified Unison.Codebase.Path as Path +import Unison.NameSegment ( NameSegment ) +import qualified Unison.NameSegment as NameSegment +import qualified Unison.Codebase.Metadata as Metadata +import qualified Unison.Hash as Hash +import Unison.Hashable ( Hashable ) +import qualified Unison.Hashable as H +import Unison.Name ( Name(..) ) +import qualified Unison.Name as Name +import qualified Unison.Names2 as Names +import qualified Unison.Names3 as Names +import Unison.Names2 ( Names'(Names), Names0 ) +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) +import qualified Unison.Referent as Referent +import qualified Unison.Reference as Reference + +import qualified U.Util.Cache as Cache +import qualified Unison.Util.Relation as R +import Unison.Util.Relation ( Relation ) +import qualified Unison.Util.Relation4 as R4 +import qualified Unison.Util.List as List +import Unison.Util.Map ( unionWithM ) +import qualified Unison.Util.Star3 as Star3 +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import qualified Unison.HashQualified as HQ +import Unison.HashQualified (HashQualified) +import qualified Unison.LabeledDependency as LD +import Unison.LabeledDependency (LabeledDependency) +import Unison.Codebase.Branch + +toNames0 :: Branch0 m -> Names0 +toNames0 b = Names (R.swap . deepTerms $ b) + (R.swap . deepTypes $ b) + +-- This stops searching for a given ShortHash once it encounters +-- any term or type in any Branch0 that satisfies that ShortHash. +findHistoricalSHs + :: Monad m => Set ShortHash -> Branch m -> m (Set ShortHash, Names0) +findHistoricalSHs = findInHistory + (\sh r _n -> sh `SH.isPrefixOf` Referent.toShortHash r) + (\sh r _n -> sh `SH.isPrefixOf` Reference.toShortHash r) + +-- This stops searching for a given HashQualified once it encounters +-- any term or type in any Branch0 that satisfies that HashQualified. +findHistoricalHQs :: Monad m + => Set (HashQualified Name) + -> Branch m + -> m (Set (HashQualified Name), Names0) +findHistoricalHQs = findInHistory + (\hq r n -> HQ.matchesNamedReferent n r hq) + (\hq r n -> HQ.matchesNamedReference n r hq) + +findHistoricalRefs :: Monad m => Set LabeledDependency -> Branch m + -> m (Set LabeledDependency, Names0) +findHistoricalRefs = findInHistory + (\query r _n -> LD.fold (const False) (==r) query) + (\query r _n -> LD.fold (==r) (const False) query) + +findHistoricalRefs' :: Monad m => Set Reference -> Branch m + -> m (Set Reference, Names0) +findHistoricalRefs' = findInHistory + (\queryRef r _n -> r == Referent.Ref queryRef) + (\queryRef r _n -> r == queryRef) + +findInHistory :: forall m q. (Monad m, Ord q) + => (q -> Referent -> Name -> Bool) + -> (q -> Reference -> Name -> Bool) + -> Set q -> Branch m -> m (Set q, Names0) +findInHistory termMatches typeMatches queries b = + (Causal.foldHistoryUntil f (queries, mempty) . _history) b <&> \case + -- could do something more sophisticated here later to report that some SH + -- couldn't be found anywhere in the history. but for now, I assume that + -- the normal thing will happen when it doesn't show up in the namespace. + Causal.Satisfied (_, names) -> (mempty, names) + Causal.Unsatisfied (missing, names) -> (missing, names) + where + -- in order to not favor terms over types, we iterate through the ShortHashes, + -- for each `remainingQueries`, if we find a matching Referent or Reference, + -- we remove `q` from the accumulated `remainingQueries`, and add the Ref* to + -- the accumulated `names0`. + f acc@(remainingQueries, _) b0 = (acc', null remainingQueries') + where + acc'@(remainingQueries', _) = foldl' findQ acc remainingQueries + findQ :: (Set q, Names0) -> q -> (Set q, Names0) + findQ acc sh = + foldl' (doType sh) (foldl' (doTerm sh) acc + (R.toList $ deepTerms b0)) + (R.toList $ deepTypes b0) + doTerm q acc@(remainingSHs, names0) (r, n) = if termMatches q r n + then (Set.delete q remainingSHs, Names.addTerm n r names0) else acc + doType q acc@(remainingSHs, names0) (r, n) = if typeMatches q r n + then (Set.delete q remainingSHs, Names.addType n r names0) else acc + +-- deepReferents :: Branch0 m -> Set Referent +-- deepReferents = R.dom . deepTerms + +-- deepTypeReferences :: Branch0 m -> Set Reference +-- deepTypeReferences = R.dom . deepTypes + +-- terms :: Lens' (Branch0 m) (Star Referent NameSegment) +-- terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) + +-- types :: Lens' (Branch0 m) (Star Reference NameSegment) +-- types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) + +-- children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) +-- children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) + +-- -- -- creates a Branch0 from the primary fields and derives the others. +-- -- branch0 :: Metadata.Star Referent NameSegment +-- -- -> Metadata.Star Reference NameSegment +-- -- -> Map NameSegment (Branch m) +-- -- -> Map NameSegment (EditHash, m Patch) +-- -- -> Branch0 m +-- -- branch0 terms types children edits = +-- -- Branch0 terms types children edits +-- -- deepTerms' deepTypes' +-- -- deepTermMetadata' deepTypeMetadata' +-- -- deepPaths' deepEdits' +-- -- where +-- -- nameSegToName = Name.unsafeFromText . NameSegment.toText +-- -- deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms +-- -- <> foldMap go (Map.toList children) +-- -- where +-- -- go (nameSegToName -> n, b) = +-- -- R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic +-- -- deepTypes' = (R.mapRan nameSegToName . Star3.d1) types +-- -- <> foldMap go (Map.toList children) +-- -- where +-- -- go (nameSegToName -> n, b) = +-- -- R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic +-- -- deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) +-- -- <> foldMap go (Map.toList children) +-- -- where +-- -- go (nameSegToName -> n, b) = +-- -- R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) +-- -- deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) +-- -- <> foldMap go (Map.toList children) +-- -- where +-- -- go (nameSegToName -> n, b) = +-- -- R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) +-- -- deepPaths' = Set.map Path.singleton (Map.keysSet children) +-- -- <> foldMap go (Map.toList children) +-- -- where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) +-- -- deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) +-- -- <> foldMap go (Map.toList children) +-- -- where +-- -- go (nameSeg, b) = +-- -- Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b + +-- -- head :: Branch m -> Branch0 m +-- -- head (Branch c) = Causal.head c + +-- headHash :: Branch m -> Hash +-- headHash (Branch c) = Causal.currentHash c + +-- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) +-- deepEdits' b = go id b where +-- -- can change this to an actual prefix once Name is a [NameSegment] +-- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) +-- go addPrefix Branch0{..} = +-- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits +-- <> foldMap f (Map.toList _children) +-- where +-- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) +-- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) + +-- data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) + +-- merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) +-- merge = merge' RegularMerge + +-- -- Discards the history of a Branch0's children, recursively +-- discardHistory0 :: Applicative m => Branch0 m -> Branch0 m +-- discardHistory0 = over children (fmap tweak) where +-- tweak b = cons (discardHistory0 (head b)) empty + +-- merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) +-- merge' = merge'' lca + +-- merge'' :: forall m . Monad m +-- => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator +-- -> MergeMode +-- -> Branch m +-- -> Branch m +-- -> m (Branch m) +-- merge'' _ _ b1 b2 | isEmpty b1 = pure b2 +-- merge'' _ mode b1 b2 | isEmpty b2 = case mode of +-- RegularMerge -> pure b1 +-- SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 +-- merge'' lca mode (Branch x) (Branch y) = +-- Branch <$> case mode of +-- RegularMerge -> Causal.threeWayMerge' lca' combine x y +-- SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y +-- where +-- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) +-- combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) +-- combine Nothing l r = merge0 lca mode l r +-- combine (Just ca) l r = do +-- dl <- diff0 ca l +-- dr <- diff0 ca r +-- head0 <- apply ca (dl <> dr) +-- children <- Map.mergeA +-- (Map.traverseMaybeMissing $ combineMissing ca) +-- (Map.traverseMaybeMissing $ combineMissing ca) +-- (Map.zipWithAMatched $ const (merge'' lca mode)) +-- (_children l) (_children r) +-- pure $ branch0 (_terms head0) (_types head0) children (_edits head0) + +-- combineMissing ca k cur = +-- case Map.lookup k (_children ca) of +-- Nothing -> pure $ Just cur +-- Just old -> do +-- nw <- merge'' lca mode (cons empty0 old) cur +-- if isEmpty0 $ head nw +-- then pure Nothing +-- else pure $ Just nw + +-- apply :: Branch0 m -> BranchDiff -> m (Branch0 m) +-- apply b0 BranchDiff {..} = do +-- patches <- sequenceA +-- $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches +-- let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) +-- makePatch Patch.PatchDiff {..} = +-- let p = Patch.Patch _addedTermEdits _addedTypeEdits +-- in (H.accumulate' p, pure p) +-- pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) +-- (Star3.difference (_types b0) removedTypes <> addedTypes) +-- (_children b0) +-- (patches <> newPatches) +-- patchMerge mhp Patch.PatchDiff {..} = Just $ do +-- (_, mp) <- mhp +-- p <- mp +-- let np = Patch.Patch +-- { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits +-- <> _addedTermEdits +-- , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits +-- <> _addedTypeEdits +-- } +-- pure (H.accumulate' np, pure np) + +-- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` +-- -- It's defined as: lca b1 b2 == Just b1 +-- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) +-- -> Branch m -> Branch m -> m Bool +-- before' lca (Branch x) (Branch y) = Causal.before' lca' x y +-- where +-- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + +-- -- `before b1 b2` is true if `b2` incorporates all of `b1` +-- before :: Monad m => Branch m -> Branch m -> m Bool +-- before (Branch b1) (Branch b2) = Causal.before b1 b2 + +-- merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) +-- -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) +-- merge0 lca mode b1 b2 = do +-- c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) +-- e3 <- unionWithM g (_edits b1) (_edits b2) +-- pure $ branch0 (_terms b1 <> _terms b2) +-- (_types b1 <> _types b2) +-- c3 +-- e3 +-- where +-- g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) +-- g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) +-- g (_, m1) (_, m2) = do +-- e1 <- m1 +-- e2 <- m2 +-- let e3 = e1 <> e2 +-- pure (H.accumulate' e3, pure e3) + +-- pattern Hash h = Causal.RawHash h + +-- toList0 :: Branch0 m -> [(Path, Branch0 m)] +-- toList0 = go Path.empty where +-- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> +-- go (Path.snoc p seg) (head cb) )) + +-- printDebugPaths :: Branch m -> String +-- printDebugPaths = unlines . map show . Set.toList . debugPaths + +-- debugPaths :: Branch m -> Set (Path, Hash) +-- debugPaths = go Path.empty where +-- go p b = Set.insert (p, headHash b) . Set.unions $ +-- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] + +-- data Target = TargetType | TargetTerm | TargetBranch +-- deriving (Eq, Ord, Show) + +-- instance Eq (Branch0 m) where +-- a == b = view terms a == view terms b +-- && view types a == view types b +-- && view children a == view children b +-- && (fmap fst . view edits) a == (fmap fst . view edits) b + +-- data ForkFailure = SrcNotFound | DestExists + +-- -- consider delegating to Names.numHashChars when ready to implement? +-- -- are those enough? +-- -- could move this to a read-only field in Branch0 +-- -- could move a Names0 to a read-only field in Branch0 until it gets too big +-- numHashChars :: Branch m -> Int +-- numHashChars _b = 3 + +-- -- This type is a little ugly, so we wrap it up with a nice type alias for +-- -- use outside this module. +-- type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) + +-- boundedCache :: MonadIO m => Word -> m (Cache m2) +-- boundedCache = Cache.semispaceCache + +-- -- Can use `Cache.nullCache` to disable caching if needed +-- cachedRead :: forall m . MonadIO m +-- => Cache m +-- -> Causal.Deserialize m Raw Raw +-- -> (EditHash -> m Patch) +-- -> Hash +-- -> m (Branch m) +-- cachedRead cache deserializeRaw deserializeEdits h = +-- Branch <$> Causal.cachedRead cache d h +-- where +-- fromRaw :: Raw -> m (Branch0 m) +-- fromRaw Raw {..} = do +-- children <- traverse go _childrenR +-- edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash +-- pure $ branch0 _termsR _typesR children edits +-- go = cachedRead cache deserializeRaw deserializeEdits +-- d :: Causal.Deserialize m Raw (Branch0 m) +-- d h = deserializeRaw h >>= \case +-- RawOne raw -> RawOne <$> fromRaw raw +-- RawCons raw h -> flip RawCons h <$> fromRaw raw +-- RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw + +-- sync +-- :: Monad m +-- => (Hash -> m Bool) +-- -> Causal.Serialize m Raw Raw +-- -> (EditHash -> m Patch -> m ()) +-- -> Branch m +-- -> m () +-- sync exists serializeRaw serializeEdits b = do +-- _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty +-- -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." +-- pure () + +-- -- serialize a `Branch m` indexed by the hash of its corresponding Raw +-- sync' +-- :: forall m +-- . Monad m +-- => (Hash -> m Bool) +-- -> Causal.Serialize m Raw Raw +-- -> (EditHash -> m Patch -> m ()) +-- -> Branch m +-- -> StateT (Set Hash) m () +-- sync' exists serializeRaw serializeEdits b = Causal.sync exists +-- serialize0 +-- (view history b) +-- where +-- serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) +-- serialize0 h b0 = case b0 of +-- RawOne b0 -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawOne (toRaw b0) +-- RawCons b0 ht -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawCons (toRaw b0) ht +-- RawMerge b0 hs -> do +-- writeB0 b0 +-- lift $ serializeRaw h $ RawMerge (toRaw b0) hs +-- where +-- writeB0 :: Branch0 m -> StateT (Set Hash) m () +-- writeB0 b0 = do +-- for_ (view children b0) $ \c -> do +-- queued <- State.get +-- when (Set.notMember (headHash c) queued) $ +-- sync' exists serializeRaw serializeEdits c +-- for_ (view edits b0) (lift . uncurry serializeEdits) + +-- -- this has to serialize the branch0 and its descendants in the tree, +-- -- and then serialize the rest of the history of the branch as well + +-- toRaw :: Branch0 m -> Raw +-- toRaw Branch0 {..} = +-- Raw _terms _types (headHash <$> _children) (fst <$> _edits) + +-- toCausalRaw :: Branch m -> Causal.Raw Raw Raw +-- toCausalRaw = \case +-- Branch (Causal.One _h e) -> RawOne (toRaw e) +-- Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht +-- Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) + +-- -- copy a path to another path +-- fork +-- :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- fork src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> case setIfNotExists dest src' root of +-- Nothing -> Left DestExists +-- Just root' -> Right root' + +-- -- Move the node at src to dest. +-- -- It's okay if `dest` is inside `src`, just create empty levels. +-- -- Try not to `step` more than once at each node. +-- move :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- move src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> +-- -- make sure dest doesn't already exist +-- case getAt dest root of +-- Just _destExists -> Left DestExists +-- Nothing -> +-- -- find and update common ancestor of `src` and `dest`: +-- Right $ modifyAt ancestor go root +-- where +-- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest +-- go = deleteAt relSrc . setAt relDest src' + +-- setIfNotExists +-- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) +-- setIfNotExists dest b root = case getAt dest root of +-- Just _destExists -> Nothing +-- Nothing -> Just $ setAt dest b root + +-- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m +-- setAt path b = modifyAt path (const b) + +-- deleteAt :: Applicative m => Path -> Branch m -> Branch m +-- deleteAt path = setAt path empty + +-- -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` +-- getAt :: Path +-- -> Branch m +-- -> Maybe (Branch m) +-- getAt path root = case Path.uncons path of +-- Nothing -> if isEmpty root then Nothing else Just root +-- Just (seg, path) -> case Map.lookup seg (_children $ head root) of +-- Just b -> getAt path b +-- Nothing -> Nothing + +-- getAt' :: Path -> Branch m -> Branch m +-- getAt' p b = fromMaybe empty $ getAt p b + +-- getAt0 :: Path -> Branch0 m -> Branch0 m +-- getAt0 p b = case Path.uncons p of +-- Nothing -> b +-- Just (seg, path) -> case Map.lookup seg (_children b) of +-- Just c -> getAt0 path (head c) +-- Nothing -> empty0 + +-- empty :: Branch m +-- empty = Branch $ Causal.one empty0 + +-- one :: Branch0 m -> Branch m +-- one = Branch . Causal.one + +-- empty0 :: Branch0 m +-- empty0 = +-- Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty + +-- isEmpty0 :: Branch0 m -> Bool +-- isEmpty0 = (== empty0) + +-- isEmpty :: Branch m -> Bool +-- isEmpty = (== empty) + +-- step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m +-- step f = \case +-- Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) +-- b -> over history (Causal.stepDistinct f) b + +-- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepM f = \case +-- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 +-- b -> mapMOf history (Causal.stepDistinctM f) b + +-- cons :: Applicative m => Branch0 m -> Branch m -> Branch m +-- cons = step . const + +-- isOne :: Branch m -> Bool +-- isOne (Branch Causal.One{}) = True +-- isOne _ = False + +-- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) +-- uncons (Branch b) = go <$> Causal.uncons b where +-- go = over (_Just . _2) Branch + +-- -- Modify the branch0 at the head of at `path` with `f`, +-- -- after creating it if necessary. Preserves history. +-- stepAt :: forall m. Applicative m +-- => Path +-- -> (Branch0 m -> Branch0 m) +-- -> Branch m -> Branch m +-- stepAt p f = modifyAt p g where +-- g :: Branch m -> Branch m +-- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b + +-- stepManyAt :: (Monad m, Foldable f) +-- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m +-- stepManyAt actions = step (stepManyAt0 actions) + +-- -- Modify the branch0 at the head of at `path` with `f`, +-- -- after creating it if necessary. Preserves history. +-- stepAtM :: forall n m. (Functor n, Applicative m) +-- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepAtM p f = modifyAtM p g where +-- g :: Branch m -> n (Branch m) +-- g (Branch b) = do +-- b0' <- f (Causal.head b) +-- pure $ Branch . Causal.consDistinct b0' $ b + +-- stepManyAtM :: (Monad m, Monad n, Foldable f) +-- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepManyAtM actions = stepM (stepManyAt0M actions) + +-- -- starting at the leaves, apply `f` to every level of the branch. +-- stepEverywhere +-- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) +-- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) +-- where children = fmap (step $ stepEverywhere f) _children + +-- -- Creates a function to fix up the children field._1 +-- -- If the action emptied a child, then remove the mapping, +-- -- otherwise update it. +-- -- Todo: Fix this in hashing & serialization instead of here? +-- getChildBranch :: NameSegment -> Branch0 m -> Branch m +-- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) + +-- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m +-- setChildBranch seg b = over children (updateChildren seg b) + +-- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch +-- getPatch seg b = case Map.lookup seg (_edits b) of +-- Nothing -> pure Patch.empty +-- Just (_, p) -> p + +-- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) +-- getMaybePatch seg b = case Map.lookup seg (_edits b) of +-- Nothing -> pure Nothing +-- Just (_, p) -> Just <$> p + +-- modifyPatches +-- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) +-- modifyPatches seg f = mapMOf edits update +-- where +-- update m = do +-- p' <- case Map.lookup seg m of +-- Nothing -> pure $ f Patch.empty +-- Just (_, p) -> f <$> p +-- let h = H.accumulate' p' +-- pure $ Map.insert seg (h, pure p') m + +-- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m +-- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) + +-- deletePatch :: NameSegment -> Branch0 m -> Branch0 m +-- deletePatch n = over edits (Map.delete n) + +-- updateChildren ::NameSegment +-- -> Branch m +-- -> Map NameSegment (Branch m) +-- -> Map NameSegment (Branch m) +-- updateChildren seg updatedChild = +-- if isEmpty updatedChild +-- then Map.delete seg +-- else Map.insert seg updatedChild + +-- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- Because it's a `Branch`, it overwrites the history at `path`. +-- modifyAt :: Applicative m +-- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m +-- modifyAt path f = runIdentity . modifyAtM path (pure . f) + +-- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- Because it's a `Branch`, it overwrites the history at `path`. +-- modifyAtM +-- :: forall n m +-- . Functor n +-- => Applicative m -- because `Causal.cons` uses `pure` +-- => Path +-- -> (Branch m -> n (Branch m)) +-- -> Branch m +-- -> n (Branch m) +-- modifyAtM path f b = case Path.uncons path of +-- Nothing -> f b +-- Just (seg, path) -> do -- Functor +-- let child = getChildBranch seg (head b) +-- child' <- modifyAtM path f child +-- -- step the branch by updating its children according to fixup +-- pure $ step (setChildBranch seg child') b + +-- -- stepManyAt0 consolidates several changes into a single step +-- stepManyAt0 :: forall f m . (Monad m, Foldable f) +-- => f (Path, Branch0 m -> Branch0 m) +-- -> Branch0 m -> Branch0 m +-- stepManyAt0 actions = +-- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] + +-- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) +-- => f (Path, Branch0 m -> n (Branch0 m)) +-- -> Branch0 m -> n (Branch0 m) +-- stepManyAt0M actions b = go (toList actions) b where +-- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) +-- go actions b = let +-- -- combines the functions that apply to this level of the tree +-- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] + +-- -- groups the actions based on the child they apply to +-- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] +-- childActions = +-- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] + +-- -- alters the children of `b` based on the `childActions` map +-- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) +-- stepChildren children0 = foldM g children0 $ Map.toList childActions +-- where +-- g children (seg, actions) = do +-- -- Recursively applies the relevant actions to the child branch +-- -- The `findWithDefault` is important - it allows the stepManyAt +-- -- to create new children at paths that don't previously exist. +-- child <- stepM (go actions) (Map.findWithDefault empty seg children0) +-- pure $ updateChildren seg child children +-- in do +-- c2 <- stepChildren (view children b) +-- currentAction (set children c2 b) + +-- instance Hashable (Branch0 m) where +-- tokens b = +-- [ H.accumulateToken (_terms b) +-- , H.accumulateToken (_types b) +-- , H.accumulateToken (headHash <$> _children b) +-- , H.accumulateToken (fst <$> _edits b) +-- ] + +-- -- getLocalBranch :: Hash -> IO Branch +-- -- getGithubBranch :: RemotePath -> IO Branch +-- -- getLocalEdit :: GUID -> IO Patch + +-- -- todo: consider inlining these into Actions2 +-- addTermName +-- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- addTermName r new md = +-- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- addTypeName +-- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- addTypeName r new md = +-- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m +-- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m + +-- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m +-- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) +-- = over terms (Star3.deletePrimaryD1 (r,n)) b +-- deleteTermName _ _ b = b + +-- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m +-- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) +-- = over types (Star3.deletePrimaryD1 (r,n)) b +-- deleteTypeName _ _ b = b + +namesDiff :: Branch m -> Branch m -> Names.Diff +namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) + +-- lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) +-- lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b + +-- diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff +-- diff0 old new = do +-- newEdits <- sequenceA $ snd <$> _edits new +-- oldEdits <- sequenceA $ snd <$> _edits old +-- let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) +-- (Map.mapMissing $ \_ p -> Patch.diff mempty p) +-- (Map.zipWithMatched (const Patch.diff)) +-- newEdits +-- oldEdits +-- pure $ BranchDiff +-- { addedTerms = Star3.difference (_terms new) (_terms old) +-- , removedTerms = Star3.difference (_terms old) (_terms new) +-- , addedTypes = Star3.difference (_types new) (_types old) +-- , removedTypes = Star3.difference (_types old) (_types new) +-- , changedPatches = diffEdits +-- } + +-- transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n +-- transform f b = case _history b of +-- causal -> Branch . Causal.transform f $ transformB0s f causal +-- where +-- transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n +-- transformB0 f b = +-- b { _children = transform f <$> _children b +-- , _edits = second f <$> _edits b +-- } + +-- transformB0s :: Functor m => (forall a . m a -> n a) +-- -> Causal m Raw (Branch0 m) +-- -> Causal m Raw (Branch0 n) +-- transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) + +-- data BranchAttentions = BranchAttentions +-- { -- Patches that were edited on the right but entirely removed on the left. +-- removedPatchEdited :: [Name] +-- -- Patches that were edited on the left but entirely removed on the right. +-- , editedPatchRemoved :: [Name] +-- } + +-- instance Semigroup BranchAttentions where +-- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 +-- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) + +-- instance Monoid BranchAttentions where +-- mempty = BranchAttentions [] [] +-- mappend = (<>) + +-- data RefCollisions = +-- RefCollisions { termCollisions :: Relation Name Name +-- , typeCollisions :: Relation Name Name +-- } deriving (Eq, Show) + +-- instance Semigroup RefCollisions where +-- (<>) = mappend +-- instance Monoid RefCollisions where +-- mempty = RefCollisions mempty mempty +-- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) +-- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs new file mode 100644 index 0000000000..0e47934d5c --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (..)) where + +import Unison.Parser.Ann (Ann) +import qualified Unison.Parser.Ann as Ann + +class BuiltinAnnotation a where + builtinAnnotation :: a + +instance BuiltinAnnotation Ann where + builtinAnnotation = Ann.Intrinsic \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/Causal.hs b/parser-typechecker/src/Unison/Codebase/Causal.hs index 08b14e9988..9317bd2863 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal.hs @@ -1,7 +1,32 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} -module Unison.Codebase.Causal where +module Unison.Codebase.Causal + ( Causal (..), + Raw (..), + RawHash (..), + one, + cons, + cons', + consDistinct, + uncons, + hash, + children, + Deserialize, + Serialize, + cachedRead, + threeWayMerge, + threeWayMerge', + squashMerge', + lca, + stepDistinct, + stepDistinctM, + sync, + transform, + unsafeMapHashPreserving, + before, + ) +where import Unison.Prelude @@ -65,27 +90,6 @@ data Causal m h e , tails :: Map (RawHash h) (m (Causal m h e)) } --- Convert the Causal to an adjacency matrix for debugging purposes. -toGraph - :: Monad m - => Set (RawHash h) - -> Causal m h e - -> m (Seq (RawHash h, RawHash h)) -toGraph seen c = case c of - One _ _ -> pure Seq.empty - Cons h1 _ (h2, m) -> if Set.notMember h1 seen - then do - tail <- m - g <- toGraph (Set.insert h1 seen) tail - pure $ (h1, h2) Seq.<| g - else pure Seq.empty - Merge h _ ts -> if Set.notMember h seen - then do - tails <- sequence $ Map.elems ts - gs <- Seq.fromList <$> traverse (toGraph (Set.insert h seen)) tails - pure $ Seq.fromList ((h, ) <$> Set.toList (Map.keysSet ts)) <> join gs - else pure Seq.empty - -- A serializer `Causal m h e`. Nonrecursive -- only responsible for -- writing a single node of the causal structure. data Raw h e @@ -93,17 +97,6 @@ data Raw h e | RawCons e (RawHash h) | RawMerge e (Set (RawHash h)) -rawHead :: Raw h e -> e -rawHead (RawOne e ) = e -rawHead (RawCons e _) = e -rawHead (RawMerge e _) = e - --- Don't need to deserialize the `e` to calculate `before`. -data Tails h - = TailsOne - | TailsCons (RawHash h) - | TailsMerge (Set (RawHash h)) - type Deserialize m h e = RawHash h -> m (Raw h e) cachedRead :: MonadIO m @@ -263,37 +256,15 @@ threeWayMerge' lca combine c1 c2 = do done newHead = Merge (RawHash (hash (newHead, Map.keys children))) newHead children -before' :: Monad m - => (Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))) - -> Causal m h e - -> Causal m h e - -> m Bool -before' lca a b = (== Just a) <$> lca a b - before :: Monad m => Causal m h e -> Causal m h e -> m Bool before a b = (== Just a) <$> lca a b hash :: Hashable e => e -> Hash hash = Hashable.accumulate' -step :: (Applicative m, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e -step f c = f (head c) `cons` c - stepDistinct :: (Applicative m, Eq e, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e stepDistinct f c = f (head c) `consDistinct` c -stepIf - :: (Applicative m, Hashable e) - => (e -> Bool) - -> (e -> e) - -> Causal m h e - -> Causal m h e -stepIf cond f c = if cond (head c) then step f c else c - -stepM - :: (Applicative m, Hashable e) => (e -> m e) -> Causal m h e -> m (Causal m h e) -stepM f c = (`cons` c) <$> f (head c) - stepDistinctM :: (Applicative m, Functor n, Eq e, Hashable e) => (e -> n e) -> Causal m h e -> n (Causal m h e) @@ -331,55 +302,3 @@ unsafeMapHashPreserving f c = case c of Merge h e tls -> Merge h (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq,Ord,Show) - --- foldHistoryUntil some condition on the accumulator is met, --- attempting to work backwards fairly through merge nodes --- (rather than following one back all the way to its root before working --- through others). Returns Unsatisfied if the condition was never satisfied, --- otherwise Satisfied. --- --- NOTE by RÓB: this short-circuits immediately and only looks at the first --- entry in the history, since this operation is far too slow to be practical. -foldHistoryUntil - :: forall m h e a - . (Monad m) - => (a -> e -> (a, Bool)) - -> a - -> Causal m h e - -> m (FoldHistoryResult a) -foldHistoryUntil f a c = step a mempty (pure c) where - step :: a -> Set (RawHash h) -> Seq (Causal m h e) -> m (FoldHistoryResult a) - step a _seen Seq.Empty = pure (Unsatisfied a) - step a seen (c Seq.:<| rest) | currentHash c `Set.member` seen = - step a seen rest - step a seen (c Seq.:<| rest) = case f a (head c) of - (a, True ) -> pure (Satisfied a) - (a, False) -> do - tails <- case c of - One{} -> pure mempty - Cons{} -> - let (_, t) = tail c - in --if h `Set.member` seen - if not (Set.null seen) then pure mempty else Seq.singleton <$> t - Merge{} -> - fmap Seq.fromList - . traverse snd - . filter (\(_, _) -> not (Set.null seen)) - . Map.toList - $ tails c - step a (Set.insert (currentHash c) seen) (rest <> tails) - -hashToRaw :: - forall m h e. Monad m => Causal m h e -> m (Map (RawHash h) [RawHash h]) -hashToRaw c = go mempty [c] where - go :: Map (RawHash h) [RawHash h] -> [Causal m h e] - -> m (Map (RawHash h) [RawHash h]) - go output [] = pure output - go output (c : queue) = case c of - One h _ -> go (Map.insert h [] output) queue - Cons h _ (htail, mctail) -> do - ctail <- mctail - go (Map.insert h [htail] output) (ctail : queue) - Merge h _ mtails -> do - tails <- sequence mtails - go (Map.insert h (Map.keys tails) output) (toList tails ++ queue) diff --git a/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs new file mode 100644 index 0000000000..44a88465ec --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} + +module Unison.Codebase.Causal.FoldHistory (FoldHistoryResult (..), foldHistoryUntil) where + +import Unison.Prelude + +import Unison.Codebase.Causal ( Causal(..), RawHash ) +import Prelude hiding (tail, head) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Map as Map + +data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq,Ord,Show) + +-- foldHistoryUntil some condition on the accumulator is met, +-- attempting to work backwards fairly through merge nodes +-- (rather than following one back all the way to its root before working +-- through others). Returns Unsatisfied if the condition was never satisfied, +-- otherwise Satisfied. +-- +-- NOTE by RÓB: this short-circuits immediately and only looks at the first +-- entry in the history, since this operation is far too slow to be practical. +foldHistoryUntil + :: forall m h e a + . (Monad m) + => (a -> e -> (a, Bool)) + -> a + -> Causal m h e + -> m (FoldHistoryResult a) +foldHistoryUntil f a c = step a mempty (pure c) where + step :: a -> Set (RawHash h) -> Seq (Causal m h e) -> m (FoldHistoryResult a) + step a _seen Seq.Empty = pure (Unsatisfied a) + step a seen (c Seq.:<| rest) | currentHash c `Set.member` seen = + step a seen rest + step a seen (c Seq.:<| rest) = case f a (head c) of + (a, True ) -> pure (Satisfied a) + (a, False) -> do + tails <- case c of + One{} -> pure mempty + Cons{} -> + let (_, t) = tail c + in --if h `Set.member` seen + if not (Set.null seen) then pure mempty else Seq.singleton <$> t + Merge{} -> + fmap Seq.fromList + . traverse snd + . filter (\(_, _) -> not (Set.null seen)) + . Map.toList + $ tails c + step a (Set.insert (currentHash c) seen) (rest <> tails) diff --git a/parser-typechecker/src/Unison/Codebase/Classes.hs b/parser-typechecker/src/Unison/Codebase/Classes.hs deleted file mode 100644 index afc6108da0..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Classes.hs +++ /dev/null @@ -1,40 +0,0 @@ - -module Unison.Codebase.Classes where --- ( GetDecls(..) --- , PutDecls(..) --- , GetBranch(..) --- , PutBranch(..) --- , GetDependents(..) --- ) where --- ---import Data.Set ( Set ) ---import Unison.Codebase.Branch ( Branch ) ---import Unison.DataDeclaration ( Decl ) ---import qualified Unison.Reference as Reference ---import Unison.Reference ( Reference ) ---import qualified Unison.Term as Term ---import qualified Unison.Type as Type ---import qualified Unison.Typechecker.TypeLookup as TL --- ---type Term v a = Term.AnnotatedTerm v a ---type Type v a = Type.AnnotatedType v a --- ---class GetDecls d m v a | d -> m v a where --- getTerm :: d -> Reference.Id -> m (Maybe (Term v a)) --- getTypeOfTerm :: d -> Reference -> m (Maybe (Type v a)) --- getTypeDeclaration :: d -> Reference.Id -> m (Maybe (Decl v a)) --- hasTerm :: d -> Reference.Id -> m Bool --- hasType :: d -> Reference.Id -> m Bool --- ---class PutDecls d m v a | d -> m v a where --- putTerm :: d -> Reference.Id -> Term v a -> Type v a -> m () --- putTypeDeclarationImpl :: d -> Reference.Id -> Decl v a -> m () --- ---class GetBranch b m | b -> m where --- getRootBranch :: b -> m (Branch m) --- ---class PutBranch b m | b -> m where --- putRootBranch :: b -> Branch m -> m () --- ---class GetDependents d m | d -> m where --- dependentsImpl :: d -> Reference -> m (Set Reference.Id) diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs index e283adbe71..13819c59ad 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs @@ -4,28 +4,31 @@ import Unison.Prelude import Control.Monad.Morph import qualified Data.Map as Map -import Unison.UnisonFile ( UnisonFile ) -import qualified Unison.UnisonFile as UF +-- import Unison.UnisonFile ( UnisonFile ) +-- import qualified Unison.UnisonFile as UF import qualified Unison.Term as Term import Unison.Term ( Term ) import Unison.Var ( Var ) import qualified Unison.Reference as Reference import Unison.DataDeclaration (Decl) +import qualified Data.Set as Set +import qualified Unison.Util.Set as Set +import qualified Unison.DataDeclaration as DD -fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a -fromUnisonFile uf = CodeLookup tm ty where - tm id = pure $ Map.lookup id termMap - ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 - typeMap1 = Map.fromList [ (id, Right dd) | - (_, (Reference.DerivedId id, dd)) <- - Map.toList (UF.dataDeclarations uf) ] - typeMap2 = Map.fromList [ (id, Left ad) | - (_, (Reference.DerivedId id, ad)) <- - Map.toList (UF.effectDeclarations uf) ] - tmm = Map.fromList (UF.terms uf) - termMap = Map.fromList [ (id, e) | - (_, (id, e)) <- - Map.toList (Term.hashComponents tmm) ] +-- fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a +-- fromUnisonFile uf = CodeLookup tm ty where +-- tm id = pure $ Map.lookup id termMap +-- ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 +-- typeMap1 = Map.fromList [ (id, Right dd) | +-- (_, (Reference.DerivedId id, dd)) <- +-- Map.toList (UF.dataDeclarations uf) ] +-- typeMap2 = Map.fromList [ (id, Left ad) | +-- (_, (Reference.DerivedId id, ad)) <- +-- Map.toList (UF.effectDeclarations uf) ] +-- tmm = Map.fromList (UF.terms uf) +-- termMap = Map.fromList [ (id, e) | +-- (_, (id, e)) <- +-- Map.toList (Term.hashComponents tmm) ] data CodeLookup v m a = CodeLookup { @@ -55,3 +58,29 @@ instance Monad m => Monoid (CodeLookup v m a) where ty id = do o <- getTypeDeclaration c1 id case o of Nothing -> getTypeDeclaration c2 id; Just _ -> pure o + +-- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? +-- todo: add some tests on this guy? +transitiveDependencies + :: (Monad m, Var v) + => CodeLookup v m a + -> Set Reference.Id + -> Reference.Id + -> m (Set Reference.Id) +transitiveDependencies code seen0 rid = if Set.member rid seen0 + then pure seen0 + else + let seen = Set.insert rid seen0 + getIds = Set.mapMaybe Reference.toId + in getTerm code rid >>= \case + Just t -> + foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) + Nothing -> + getTypeDeclaration code rid >>= \case + Nothing -> pure seen + Just (Left ed) -> foldM (transitiveDependencies code) + seen + (getIds $ DD.dependencies (DD.toDataDecl ed)) + Just (Right dd) -> foldM (transitiveDependencies code) + seen + (getIds $ DD.dependencies dd) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs new file mode 100644 index 0000000000..be7e3f9cdd --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs @@ -0,0 +1,30 @@ +module Unison.Codebase.CodeLookup.Util where + +import Unison.Prelude + +import Control.Monad.Morph +import qualified Data.Map as Map +import Unison.Codebase.CodeLookup +import Unison.DataDeclaration (Decl) +import qualified Unison.Reference as Reference +import Unison.Term (Term) +import qualified Unison.Term as Term +import qualified Unison.UnisonFile as UF +import Unison.UnisonFile.Type (UnisonFile) +import Unison.Var (Var) +import qualified Unison.UnisonFile.Type as UF + +fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a +fromUnisonFile uf = CodeLookup tm ty where + tm id = pure $ Map.lookup id termMap + ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 + typeMap1 = Map.fromList [ (id, Right dd) | + (_, (Reference.DerivedId id, dd)) <- + Map.toList (UF.dataDeclarations uf) ] + typeMap2 = Map.fromList [ (id, Left ad) | + (_, (Reference.DerivedId id, ad)) <- + Map.toList (UF.effectDeclarations uf) ] + tmm = Map.fromList (UF.terms uf) + termMap = Map.fromList [ (id, e) | + (_, (id, e)) <- + Map.toList (Term.hashComponents tmm) ] diff --git a/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs b/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs index 8ef7a60c87..7e56721cca 100644 --- a/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs +++ b/parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs @@ -64,10 +64,10 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type -import Unison.UnisonFile (WatchKind) import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as Relation import Unison.Util.Star3 (Star3 (Star3)) +import Unison.WatchKind (WatchKind) debug :: Bool debug = False diff --git a/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs b/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs deleted file mode 100644 index f789c02af2..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.Conversion.Upgrade12 where - -import Control.Exception.Safe (MonadCatch) -import Control.Lens (Lens', (&), (.~), (^.)) -import qualified Control.Lens as Lens -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import qualified Control.Monad.Reader as Reader -import Control.Monad.State (StateT (StateT, runStateT)) -import qualified Control.Monad.State as State -import Control.Monad.Trans (lift) -import qualified Data.Map as Map -import qualified U.Codebase.Sync as Sync -import Unison.Codebase (CodebasePath) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch (Branch (Branch)) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Conversion.Sync12 as Sync12 -import qualified Unison.Codebase.FileCodebase as FC -import qualified Unison.Codebase.Init as Codebase -import qualified Unison.Codebase.SqliteCodebase as SC -import qualified Unison.PrettyTerminal as CT -import Unison.UnisonFile (WatchKind) -import qualified Unison.UnisonFile as WK -import UnliftIO (MonadIO, liftIO) - -syncWatchKinds :: [WatchKind] -syncWatchKinds = [WK.TestWatch] - -upgradeCodebase :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m () -upgradeCodebase root = do - either (liftIO . CT.putPrettyLn) pure =<< runExceptT do - (cleanupSrc, srcCB) <- ExceptT $ Codebase.openCodebase FC.init "upgradeCodebase srcCB" root - (cleanupDest, destCB) <- ExceptT $ Codebase.createCodebase SC.init "upgradeCodebase destCB" root - destDB <- SC.unsafeGetConnection "upgradeCodebase destDB" root - let env = Sync12.Env srcCB destCB destDB - let initialState = (Sync12.emptyDoneCount, Sync12.emptyErrorCount, Sync12.emptyStatus) - rootEntity <- - lift (Codebase.getRootBranch srcCB) >>= \case - Left e -> error $ "Error loading source codebase root branch: " ++ show e - Right (Branch c) -> pure $ Sync12.C (Causal.currentHash c) (pure c) - watchResults <- - lift $ - concat - <$> traverse - (\k -> fmap (Sync12.W k) <$> Codebase.watches srcCB k) - syncWatchKinds - (_, _, s) <- flip Reader.runReaderT env . flip State.execStateT initialState $ do - sync <- Sync12.sync12 (lift . lift . lift) - Sync.sync @_ @(Sync12.Entity _) - (Sync.transformSync (lensStateT Lens._3) sync) - Sync12.simpleProgress - (rootEntity : watchResults) - lift $ - Codebase.putRootBranch destCB =<< fmap Branch case rootEntity of - Sync12.C h mc -> case Map.lookup h (Sync12._branchStatus s) of - Just Sync12.BranchOk -> mc - Just (Sync12.BranchReplaced _h' c') -> pure c' - Nothing -> error "We didn't sync the root?" - _ -> error "The root wasn't a causal?" - SC.shutdownConnection destDB - lift cleanupSrc - lift cleanupDest - pure () - where - lensStateT :: forall m s1 s2 a. Monad m => Lens' s2 s1 -> StateT s1 m a -> StateT s2 m a - lensStateT l m = StateT \s2 -> do - (a, s1') <- runStateT m (s2 ^. l) - pure (a, s2 & l .~ s1') diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index a3110f0514..b0598e31e5 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -31,11 +31,12 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Branch ( Branch ) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch import Unison.Codebase.GitError import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.SyncMode ( SyncMode ) import Unison.Names3 ( Names, Names0 ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import Unison.Referent ( Referent ) import Unison.Reference ( Reference ) import Unison.Result ( Note @@ -60,6 +61,8 @@ import Unison.Name (Name) import Unison.Server.QueryResult (QueryResult) import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.WatchKind as WK +import Unison.Codebase.Type (GitError) type AmbientAbilities v = [Type v Ann] type SourceName = Text @@ -160,10 +163,10 @@ data Command m i v a where Evaluate1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> Command m i v (Either Runtime.Error (Term v Ann)) -- Add a cached watch to the codebase - PutWatch :: UF.WatchKind -> Reference.Id -> Term v Ann -> Command m i v () + PutWatch :: WK.WatchKind -> Reference.Id -> Term v Ann -> Command m i v () -- Loads any cached watches of the given kind - LoadWatches :: UF.WatchKind -> Set Reference -> Command m i v [(Reference, Term v Ann)] + LoadWatches :: WK.WatchKind -> Set Reference -> Command m i v [(Reference, Term v Ann)] -- Loads a root branch from some codebase, returning `Nothing` if not found. -- Any definitions in the head of the requested root that aren't in the local @@ -196,7 +199,7 @@ data Command m i v a where AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v () -- load the reflog in file (chronological) order - LoadReflog :: Command m i v [Reflog.Entry] + LoadReflog :: Command m i v [Reflog.Entry Branch.Hash] LoadTerm :: Reference.Id -> Command m i v (Maybe (Term v Ann)) @@ -237,7 +240,7 @@ type UseCache = Bool type EvalResult v = ( [(v, Term v ())] - , Map v (Ann, UF.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit) + , Map v (Ann, WK.WatchKind, Reference, Term v (), Term v (), Runtime.IsCacheHit) ) lookupEvalResult :: Ord v => v -> EvalResult v -> Maybe (Term v ()) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 7184c5d95a..18ab1153f5 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Editor.Git where +module Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch, withIOError, withStatus) where import Unison.Prelude @@ -11,16 +11,16 @@ import qualified Data.Text as Text import Shellmet (($?), ($^), ($|)) import System.FilePath (()) import Unison.Codebase.Editor.RemoteRepo (ReadRepo (ReadGitRepo)) -import Unison.Codebase.GitError (GitError) import qualified Unison.Codebase.GitError as GitError +import Unison.CodebasePath (CodebasePath) import qualified Unison.Util.Exception as Ex import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory, removeDirectoryRecursive) import UnliftIO.IO (hFlush, stdout) import qualified Data.ByteString.Base16 as ByteString import qualified Data.Char as Char import Control.Exception.Safe (catchIO, MonadCatch) +import Unison.Codebase.GitError (GitProtocolError) -type CodebasePath = FilePath -- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os encodeFileName :: String -> FilePath @@ -56,7 +56,7 @@ withStatus str ma = do -- | Given a remote git repo url, and branch/commit hash (currently -- not allowed): checks for git, clones or updates a cached copy of the repo -pullBranch :: (MonadIO m, MonadCatch m, MonadError GitError m) => ReadRepo -> m CodebasePath +pullBranch :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m) => ReadRepo -> m CodebasePath pullBranch repo@(ReadGitRepo uri) = do checkForGit localPath <- tempGitDir uri @@ -64,14 +64,14 @@ pullBranch repo@(ReadGitRepo uri) = do -- try to update existing directory (ifM (isGitRepo localPath) (checkoutExisting localPath) - (throwError (GitError.UnrecognizableCacheDir uri localPath))) + (throwError (GitError.UnrecognizableCacheDir repo localPath))) -- directory doesn't exist, so clone anew (checkOutNew localPath Nothing) pure localPath where -- | Do a `git clone` (for a not-previously-cached repo). - checkOutNew :: (MonadIO m, MonadError GitError m) => CodebasePath -> Maybe Text -> m () + checkOutNew :: (MonadIO m, MonadError GitProtocolError m) => CodebasePath -> Maybe Text -> m () checkOutNew localPath branch = do withStatus ("Downloading from " ++ Text.unpack uri ++ " ...") $ (liftIO $ @@ -80,10 +80,10 @@ pullBranch repo@(ReadGitRepo uri) = do ++ [uri, Text.pack localPath])) `withIOError` (throwError . GitError.CloneException repo . show) isGitDir <- liftIO $ isGitRepo localPath - unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir uri localPath + unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath -- | Do a `git pull` on a cached repo. - checkoutExisting :: (MonadIO m, MonadCatch m, MonadError GitError m) => FilePath -> m () + checkoutExisting :: (MonadIO m, MonadCatch m, MonadError GitProtocolError m) => FilePath -> m () checkoutExisting localPath = ifM (isEmptyGitRepo localPath) -- I don't know how to properly update from an empty remote repo. @@ -99,7 +99,7 @@ pullBranch repo@(ReadGitRepo uri) = do (const $ goFromScratch)) where - goFromScratch :: (MonadIO m, MonadError GitError m) => m () + goFromScratch :: (MonadIO m, MonadError GitProtocolError m) => m () goFromScratch = do wipeDir localPath; checkOutNew localPath Nothing isEmptyGitRepo :: MonadIO m => FilePath -> m Bool @@ -113,11 +113,11 @@ pullBranch repo@(ReadGitRepo uri) = do e <- Ex.tryAny . whenM (doesDirectoryExist localPath) $ removeDirectoryRecursive localPath case e of - Left e -> throwError (GitError.SomeOtherError (show e)) + Left e -> throwError (GitError.CleanupError e) Right _ -> pure () -- | See if `git` is on the system path. -checkForGit :: MonadIO m => MonadError GitError m => m () +checkForGit :: MonadIO m => MonadError GitProtocolError m => m () checkForGit = do gitPath <- liftIO $ findExecutable "git" when (isNothing gitPath) $ throwError GitError.NoGit diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index f88e6c70c4..e3515575d4 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -26,7 +26,8 @@ import Unison.Codebase ( Codebase ) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch ( Branch ) import qualified Unison.Codebase.Branch as Branch -import Unison.Parser ( Ann ) +import qualified Unison.Codebase.Branch.Merge as Branch +import Unison.Parser.Ann (Ann) import qualified Unison.Parser as Parser import qualified Unison.Parsers as Parsers import qualified Unison.Reference as Reference @@ -45,6 +46,8 @@ import qualified Unison.PrettyPrintEnv as PPE import Unison.Term (Term) import Unison.Type (Type) import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo +import qualified Unison.Parser.Ann as Ann +import qualified Unison.WatchKind as WK typecheck :: (Monad m, Var v) @@ -170,7 +173,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour lift $ evalUnisonFile ppe uf AppendToReflog reason old new -> lift $ Codebase.appendReflog codebase reason old new LoadReflog -> lift $ Codebase.getReflog codebase - CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Parser.External t + CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Ann.External t HQNameQuery mayPath branch query -> lift $ Backend.hqNameQuery mayPath branch codebase query LoadSearchResults srs -> lift $ Backend.loadSearchResults codebase srs @@ -180,8 +183,8 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour ClearWatchCache -> lift $ Codebase.clearWatches codebase watchCache (Reference.DerivedId h) = do - m1 <- Codebase.getWatch codebase UF.RegularWatch h - m2 <- maybe (Codebase.getWatch codebase UF.TestWatch h) (pure . Just) m1 + m1 <- Codebase.getWatch codebase WK.RegularWatch h + m2 <- maybe (Codebase.getWatch codebase WK.TestWatch h) (pure . Just) m1 pure $ Term.amap (const ()) <$> m2 watchCache Reference.Builtin{} = pure Nothing @@ -191,19 +194,15 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour cache = if useCache then watchCache else Runtime.noCache r <- Runtime.evaluateTerm' codeLookup cache ppe rt tm when useCache $ case r of - Right tmr -> Codebase.putWatch codebase UF.RegularWatch (Term.hashClosedTerm tm) - (Term.amap (const Parser.External) tmr) + Right tmr -> Codebase.putWatch codebase WK.RegularWatch (Term.hashClosedTerm tm) + (Term.amap (const Ann.External) tmr) Left _ -> pure () - pure $ r <&> Term.amap (const Parser.External) + pure $ r <&> Term.amap (const Ann.External) evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> _ evalUnisonFile ppe (UF.discardTypes -> unisonFile) = do let codeLookup = Codebase.toCodeLookup codebase - evalFile <- - if Runtime.needsContainment rt - then Codebase.makeSelfContained' codeLookup unisonFile - else pure unisonFile - r <- Runtime.evaluateWatches codeLookup ppe watchCache rt evalFile + r <- Runtime.evaluateWatches codeLookup ppe watchCache rt unisonFile case r of Left e -> pure (Left e) Right rs@(_,map) -> do @@ -211,7 +210,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour if isHit then pure () else case hash of Reference.DerivedId h -> do - let value' = Term.amap (const Parser.External) value + let value' = Term.amap (const Ann.External) value Codebase.putWatch codebase kind h value' Reference.Builtin{} -> pure () pure $ Right rs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 6d6249eca0..d6ca11e578 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -60,6 +60,8 @@ import Unison.Codebase.Branch ( Branch(..) , Branch0(..) ) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.BranchUtil as BranchUtil import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN @@ -69,6 +71,7 @@ import qualified Unison.Codebase.Patch as Patch import Unison.Codebase.Path ( Path , Path'(..) ) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Reflog as Reflog import Unison.Server.SearchResult ( SearchResult ) import qualified Unison.Server.SearchResult as SR @@ -86,7 +89,7 @@ import Unison.Names3 ( Names(..), Names0 , pattern Names0 ) import qualified Unison.Names2 as Names import qualified Unison.Names3 as Names3 -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann(..)) import Unison.Reference ( Reference(..) ) import qualified Unison.Reference as Reference import Unison.Referent ( Referent ) @@ -96,8 +99,10 @@ import qualified Unison.ShortHash as SH import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.Type as Type +import qualified Unison.Type.Names as Type import qualified Unison.Result as Result import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF import qualified Unison.Util.Find as Find import Unison.Util.Free ( Free ) import qualified Unison.Util.Free as Free @@ -111,8 +116,13 @@ import qualified Unison.Var as Var import qualified Unison.Codebase.TypeEdit as TypeEdit import Unison.Codebase.TermEdit (TermEdit(..)) import qualified Unison.Codebase.TermEdit as TermEdit +import qualified Unison.Codebase.TermEdit.Typing as TermEdit import qualified Unison.Typechecker as Typechecker +import qualified Unison.WatchKind as WK import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.PrettyPrintEnvDecl.Names as PPE import Unison.Runtime.IOSource ( isTest ) import qualified Unison.Runtime.IOSource as IOSource import qualified Unison.Util.Monoid as Monoid @@ -672,7 +682,7 @@ loop = do -- discontinuity in the reflog. convertEntries :: Maybe Branch.Hash -> [Output.ReflogEntry] - -> [Reflog.Entry] + -> [Reflog.Entry Branch.Hash] -> [Output.ReflogEntry] convertEntries _ acc [] = acc convertEntries Nothing acc entries@(Reflog.Entry old _ _ : _) = @@ -1539,7 +1549,7 @@ loop = do | (r, Term.List' ts) <- Map.toList results , Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts , cid == DD.failConstructorId && ref == DD.testResultRef ] - cachedTests <- fmap Map.fromList . eval $ LoadWatches UF.TestWatch testRefs + cachedTests <- fmap Map.fromList . eval $ LoadWatches WK.TestWatch testRefs let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) names <- makePrintNamesFromLabeled' $ LD.referents testTerms <> @@ -1564,7 +1574,7 @@ loop = do Left e -> respond (EvaluationFailure e) $> [] Right tm' -> do -- After evaluation, cache the result of the test - eval $ PutWatch UF.TestWatch rid tm' + eval $ PutWatch WK.TestWatch rid tm' respond $ TestIncrementalOutputEnd ppe (n,total) r tm' pure [(r, tm')] r -> error $ "unpossible, tests can't be builtins: " <> show r @@ -1763,9 +1773,6 @@ loop = do numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing) respond $ ListDependencies hqLength ld names missing DebugNumberedArgsI -> use numberedArgs >>= respond . DumpNumberedArgs - DebugBranchHistoryI -> - eval . Notify . DumpBitBooster (Branch.headHash currentBranch') =<< - (eval . Eval $ Causal.hashToRaw (Branch._history currentBranch')) DebugTypecheckedUnisonFileI -> case uf of Nothing -> respond NoUnisonFile Just uf -> let @@ -2591,7 +2598,7 @@ doSlurpAdds slurp uf = Branch.stepManyAt0 (typeActions <> termActions) termActions = map doTerm . toList $ SC.terms slurp <> Slurp.constructorsFor (SC.types slurp) uf names = UF.typecheckedToNames0 uf - tests = Set.fromList $ fst <$> UF.watchesOfKind UF.TestWatch (UF.discardTypes uf) + tests = Set.fromList $ fst <$> UF.watchesOfKind WK.TestWatch (UF.discardTypes uf) (isTestType, isTestValue) = isTest md v = if Set.member v tests then Metadata.singleton isTestType isTestValue @@ -2840,7 +2847,7 @@ addWatch watchName (Just uf) = do (UF.dataDeclarationsId' uf) (UF.effectDeclarationsId' uf) (UF.topLevelComponents' uf) - (UF.watchComponents uf <> [(UF.RegularWatch, [(v2, Term.var a v, ty)])])) + (UF.watchComponents uf <> [(WK.RegularWatch, [(v2, Term.var a v, ty)])])) _ -> addWatch watchName Nothing -- Given a typechecked file with a main function called `mainName` diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 793c1a379b..978762b838 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -9,11 +9,13 @@ module Unison.Codebase.Editor.Input import Unison.Prelude -import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' import Unison.Codebase.Path ( Path' ) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.Editor.RemoteRepo import Unison.ShortHash (ShortHash) import Unison.Codebase.ShortBranchHash (ShortBranchHash) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index f5d34ee3a0..da7bac4af6 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -21,12 +21,12 @@ import Unison.Server.Backend (ShallowListEntry(..)) import Unison.Codebase.Editor.Input import Unison.Codebase (GetRootBranchError) import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) -import Unison.Codebase.GitError import Unison.Codebase.Path (Path') import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Type (GitError) import Unison.Name ( Name ) import Unison.Names2 ( Names ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Reference as Reference import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) @@ -41,6 +41,7 @@ import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' import qualified Unison.Parser as Parser import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Typechecker.Context as Context import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P @@ -49,6 +50,7 @@ import qualified Unison.Codebase.Editor.TodoOutput as TO import Unison.Server.SearchResult' (SearchResult') import Unison.Term (Term) import Unison.Type (Type) +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Names3 as Names import qualified Data.Set as Set import Unison.NameSegment (NameSegment) @@ -57,6 +59,7 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.WatchKind as WK type ListDetailed = Bool type SourceName = Text @@ -152,7 +155,7 @@ data Output v | Evaluated SourceFileContents PPE.PrettyPrintEnv [(v, Term v ())] - (Map v (Ann, UF.WatchKind, Term v (), Runtime.IsCacheHit)) + (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) -- "display" definitions, possibly to a FilePath on disk (e.g. editing) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs index 9ec10150f8..61e19526e6 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs @@ -14,6 +14,7 @@ import qualified Data.Set as Set import Unison.Codebase.Branch ( Branch0(..) ) import Unison.Prelude import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Command import Unison.Codebase.Editor.Output import Unison.Codebase.Patch ( Patch(..) ) @@ -22,7 +23,7 @@ import Unison.DataDeclaration ( Decl ) import qualified Unison.DataDeclaration as Decl import Unison.Names3 ( Names0 ) import qualified Unison.Names2 as Names -import Unison.Parser ( Ann(..) ) +import Unison.Parser.Ann (Ann(..)) import Unison.Reference ( Reference(..) ) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent @@ -39,6 +40,7 @@ import qualified Unison.Codebase.Metadata as Metadata import qualified Unison.Codebase.TypeEdit as TypeEdit import Unison.Codebase.TermEdit ( TermEdit(..) ) import qualified Unison.Codebase.TermEdit as TermEdit +import qualified Unison.Codebase.TermEdit.Typing as TermEdit import Unison.Codebase.TypeEdit ( TypeEdit(..) ) import Unison.UnisonFile ( UnisonFile(..) ) import qualified Unison.UnisonFile as UF diff --git a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs index a65d80f183..5fea36a63d 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs @@ -9,7 +9,7 @@ import Unison.Prelude import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..)) import Unison.Name ( Name ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann ( Ann ) import Unison.Var (Var) import qualified Data.Map as Map import qualified Data.Set as Set @@ -23,6 +23,7 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import qualified Unison.TypePrinter as TP import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF import qualified Unison.Util.Monoid as Monoid import qualified Unison.Util.Pretty as P import qualified Unison.Util.Relation as R diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index b545d1063e..9003c37e17 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -15,13 +15,14 @@ import Unison.Prelude import Unison.Codebase.MainTerm ( getMainTerm ) import qualified Unison.Codebase.MainTerm as MainTerm import qualified Unison.Codebase as Codebase -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Codebase.Runtime as Runtime import Unison.Codebase.Runtime ( Runtime ) import Unison.Var ( Var ) import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Names3 as Names3 import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import System.Exit (die) import Control.Exception (finally) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs index 3e44ee25de..99e56a4aef 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs @@ -6,38 +6,39 @@ {-# LANGUAGE ViewPatterns #-} module Unison.Codebase.FileCodebase - ( - codebase1', -- used by Test/Git + ( codebase1', -- used by Test/Git Unison.Codebase.FileCodebase.init, - openCodebase -- since init requires a bunch of irrelevant args now + openCodebase, -- since init requires a bunch of irrelevant args now ) where import Control.Concurrent (forkIO, killThread) import Control.Exception.Safe (MonadCatch, catchIO) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.Extra ((||^)) +import Control.Monad.Trans.Except (withExceptT) import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as TextIO import System.Directory (canonicalizePath) -import System.FilePath (dropExtension) -import Unison.Codebase (BuiltinAnnotation, Codebase (Codebase), CodebasePath) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch (Branch) -import qualified Unison.Codebase.Branch as Branch -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.Extra ((||^)) -import System.FilePath (()) +import System.FilePath (dropExtension, ()) import qualified U.Util.Cache as Cache -import qualified Unison.Codebase.Init as Codebase -import Unison.Codebase.Branch (headHash) +import U.Util.Timing (time) +import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation) import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch, withIOError, withStatus) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), writeToRead, printWriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), printWriteRepo, writeToRead) +import Unison.Codebase.FileCodebase.Branch (Branch, headHash) +import qualified Unison.Codebase.FileCodebase.Branch as Branch +import Unison.Codebase.FileCodebase.Codebase (Codebase (Codebase), CodebasePath, GitError (GitCodebaseError, GitFileCodebaseError, GitProtocolError)) +import qualified Unison.Codebase.FileCodebase.Codebase as Codebase +import Unison.Codebase.Causal (RawHash(RawHash)) import Unison.Codebase.FileCodebase.Common ( Err (CantParseBranchHead), branchFromFiles, branchHashesByPrefix, branchHeadDir, codebaseExists, + codebasePath, componentIdFromString, decodeFileName, dependentsDir, @@ -67,32 +68,30 @@ import Unison.Codebase.FileCodebase.Common typeMentionsIndexDir, typeReferencesByPrefix, updateCausalHead, - watchesDir, codebasePath + watchesDir, ) import qualified Unison.Codebase.FileCodebase.Common as Common +import qualified Unison.Codebase.FileCodebase.Init as Codebase (CreateCodebaseError (..), Init (Init), Pretty) +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 (formatSymbol) import qualified Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex as Sync -import Unison.Codebase.GitError (GitError) -import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Reflog as Reflog -import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 +import qualified Unison.Codebase.Reflog as Reflog (Entry (..), fromText, toText) +import qualified Unison.Codebase.Serialization as S (Format (..)) import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.Codebase.Watch as Watch -import Unison.Parser (Ann ()) +import qualified Unison.Codebase.Watch as Watch (collectUntilPause, watchDirectory') +import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Reference (Reference) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent import Unison.Symbol (Symbol) -import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as TQueue -import U.Util.Timing (time) import Unison.Var (Var) +import Unison.WatchKind (WatchKind) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) import UnliftIO.STM (atomically) - +import qualified Unison.Codebase.GitError as GitError init :: (MonadIO m, MonadCatch m) => Codebase.Init m Symbol Ann init = Codebase.Init (const $ (fmap . fmap) (pure (),) . openCodebase) @@ -209,14 +208,14 @@ codebase1' syncToDirectory branchCache fmtV@(S.Format getV putV) fmtA@(S.Format ls <- fmap decodeFileName <$> listDirectory d pure . Set.fromList $ ls >>= (toList . referentIdFromString) else pure Set.empty - watches :: UF.WatchKind -> m [Reference.Id] + watches :: WatchKind -> m [Reference.Id] watches k = liftIO $ do let wp = watchesDir path (Text.pack k) createDirectoryIfMissing True wp ls <- listDirectory wp pure $ ls >>= (toList . componentIdFromString . dropExtension) - getReflog :: m [Reflog.Entry] + getReflog :: m [Reflog.Entry Branch.Hash] getReflog = liftIO (do contents <- TextIO.readFile (reflogPath path) @@ -266,26 +265,26 @@ viewRemoteBranch' :: forall m. (MonadIO m, MonadCatch m) => Branch.Cache m -> ReadRemoteNamespace -> ExceptT GitError m (Branch m, CodebasePath) viewRemoteBranch' cache (repo, sbh, path) = do -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch repo + remotePath <- time "Git fetch" . withExceptT GitProtocolError $ pullBranch repo -- try to load the requested branch from it branch <- time "Git fetch (sbh)" $ case sbh of -- load the root branch Nothing -> lift (getRootBranch cache remotePath) >>= \case Left Codebase.NoRootBranch -> pure Branch.empty Left (Codebase.CouldntLoadRootBranch h) -> - throwError $ GitError.CouldntLoadRootBranch repo h + throwError . GitCodebaseError $ GitError.CouldntLoadRootBranch repo h Left (Codebase.CouldntParseRootBranch s) -> - throwError $ GitError.CouldntParseRootBranch repo s + throwError . GitFileCodebaseError $ Codebase.GitCouldntParseRootBranchHash repo s Right b -> pure b -- load from a specific `ShortBranchHash` Just sbh -> do branchCompletions <- lift $ branchHashesByPrefix remotePath sbh case toList branchCompletions of - [] -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh + [] -> throwError . GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh [h] -> (lift $ branchFromFiles cache remotePath h) >>= \case Just b -> pure b - Nothing -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh - _ -> throwError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions + Nothing -> throwError . GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh + _ -> throwError . GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions pure (Branch.getAt' path branch, remotePath) -- Given a branch that is "after" the existing root of a given git repo, @@ -301,7 +300,7 @@ pushGitRootBranch pushGitRootBranch syncToDirectory cache branch repo syncMode = do -- Pull the remote repo into a staging directory (remoteRoot, remotePath) <- viewRemoteBranch' cache (writeToRead repo, Nothing, Path.empty) - ifM (pure (remoteRoot == Branch.empty) + withExceptT GitProtocolError $ ifM (pure (remoteRoot == Branch.empty) ||^ lift (remoteRoot `Branch.before` branch)) -- ours is newer 👍, meaning this is a fast-forward push, -- so sync branch to staging area diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs new file mode 100644 index 0000000000..1325ad6ada --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs @@ -0,0 +1,783 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Unison.Codebase.FileCodebase.Branch + ( -- * Branch types + Branch(..) + , UnwrappedBranch + , Branch0(..) + , Raw(..) + , Star + , Hash + , EditHash + , pattern Hash + -- * Branch construction + , empty + , branch0 + , toCausalRaw + , transform + , headHash + , before + , merge + -- ** Children lenses + , children + -- ** Children queries + , getAt' + -- * Branch terms/types/edits + -- ** Term/type/edits lenses + , terms + , types + , edits + -- * Branch serialization + , cachedRead + , Cache + , sync + ) where + +import Unison.Prelude hiding (empty) + +import Prelude hiding (head,read,subtract) + +import Control.Lens hiding ( children, cons, transform, uncons ) +import qualified Control.Monad.State as State +import Control.Monad.State ( StateT ) +import Data.Bifunctor ( second ) +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map +import qualified Data.Set as Set +import qualified Unison.Codebase.FileCodebase.Patch as Patch +import Unison.Codebase.FileCodebase.Patch (Patch) +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.Causal ( Causal + , pattern RawOne + , pattern RawCons + , pattern RawMerge + ) +import Unison.Codebase.Path ( Path(..) ) +import qualified Unison.Codebase.Path as Path +import Unison.NameSegment ( NameSegment ) +import qualified Unison.NameSegment as NameSegment +import qualified Unison.Codebase.FileCodebase.Metadata as Metadata +import qualified Unison.Hash as Hash +import Unison.Hashable ( Hashable ) +import qualified Unison.Hashable as H +import Unison.Name ( Name(..) ) +import qualified Unison.Name as Name +import Unison.Codebase.FileCodebase.Reference (Reference) +import Unison.Codebase.FileCodebase.Referent (Referent) + +import qualified U.Util.Cache as Cache +import qualified Unison.Util.Relation as R +import Unison.Util.Relation ( Relation ) +import qualified Unison.Util.Relation4 as R4 +import Unison.Util.Map ( unionWithM ) +import qualified Unison.Util.Star3 as Star3 + +-- | 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) + +type Hash = Causal.RawHash Raw +type EditHash = Hash.Hash + +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` + , deepTerms :: Relation Referent Name + , deepTypes :: Relation Reference Name + , deepTermMetadata :: Metadata.R4 Referent Name + , deepTypeMetadata :: Metadata.R4 Reference Name + , deepPaths :: Set Path + , deepEdits :: Map Name EditHash + } + +-- Represents a shallow diff of a Branch0. +-- Each of these `Star`s contain metadata as well, so an entry in +-- `added` or `removed` could be an update to the metadata. +data BranchDiff = BranchDiff + { addedTerms :: Star Referent NameSegment + , removedTerms :: Star Referent NameSegment + , addedTypes :: Star Reference NameSegment + , removedTypes :: Star Reference NameSegment + , changedPatches :: Map NameSegment Patch.PatchDiff + } deriving (Eq, Ord, Show) + +instance Semigroup BranchDiff where + left <> right = BranchDiff + { addedTerms = addedTerms left <> addedTerms right + , removedTerms = removedTerms left <> removedTerms right + , addedTypes = addedTypes left <> addedTypes right + , removedTypes = removedTypes left <> removedTypes right + , changedPatches = + Map.unionWith (<>) (changedPatches left) (changedPatches right) + } + +instance Monoid BranchDiff where + mappend = (<>) + mempty = BranchDiff mempty mempty mempty mempty mempty + +-- The raw Branch +data Raw = Raw + { _termsR :: Star Referent NameSegment + , _typesR :: Star Reference NameSegment + , _childrenR :: Map NameSegment Hash + , _editsR :: Map NameSegment EditHash + } + +makeLenses ''Branch +makeLensesFor [("_edits", "edits")] ''Branch0 + +terms :: Lens' (Branch0 m) (Star Referent NameSegment) +terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) + +types :: Lens' (Branch0 m) (Star Reference NameSegment) +types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) + +children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) +children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) + +-- creates a Branch0 from the primary fields and derives the others. +branch0 :: Metadata.Star Referent NameSegment + -> Metadata.Star Reference NameSegment + -> Map NameSegment (Branch m) + -> Map NameSegment (EditHash, m Patch) + -> Branch0 m +branch0 terms types children edits = + Branch0 terms types children edits + deepTerms' deepTypes' + deepTermMetadata' deepTypeMetadata' + deepPaths' deepEdits' + where + nameSegToName = Name.unsafeFromText . NameSegment.toText + deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms + <> foldMap go (Map.toList children) + where + go (nameSegToName -> n, b) = + R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic + deepTypes' = (R.mapRan nameSegToName . Star3.d1) types + <> foldMap go (Map.toList children) + where + go (nameSegToName -> n, b) = + R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic + deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) + <> foldMap go (Map.toList children) + where + go (nameSegToName -> n, b) = + R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) + deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) + <> foldMap go (Map.toList children) + where + go (nameSegToName -> n, b) = + R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) + deepPaths' = Set.map Path.singleton (Map.keysSet children) + <> foldMap go (Map.toList children) + where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) + deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) + <> foldMap go (Map.toList children) + where + go (nameSeg, b) = + Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b + +head :: Branch m -> Branch0 m +head (Branch c) = Causal.head c + +headHash :: Branch m -> Hash +headHash (Branch c) = Causal.currentHash c + +-- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) +-- deepEdits' b = go id b where +-- -- can change this to an actual prefix once Name is a [NameSegment] +-- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) +-- go addPrefix Branch0{..} = +-- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits +-- <> foldMap f (Map.toList _children) +-- where +-- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) +-- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) + +data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) + +merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) +merge = merge' RegularMerge + +-- Discards the history of a Branch0's children, recursively +discardHistory0 :: Applicative m => Branch0 m -> Branch0 m +discardHistory0 = over children (fmap tweak) where + tweak b = cons (discardHistory0 (head b)) empty + +merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) +merge' = merge'' lca + +merge'' :: forall m . Monad m + => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator + -> MergeMode + -> Branch m + -> Branch m + -> m (Branch m) +merge'' _ _ b1 b2 | isEmpty b1 = pure b2 +merge'' _ mode b1 b2 | isEmpty b2 = case mode of + RegularMerge -> pure b1 + SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 +merge'' lca mode (Branch x) (Branch y) = + Branch <$> case mode of + RegularMerge -> Causal.threeWayMerge' lca' combine x y + SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y + where + lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) + combine Nothing l r = merge0 lca mode l r + combine (Just ca) l r = do + dl <- diff0 ca l + dr <- diff0 ca r + head0 <- apply ca (dl <> dr) + children <- Map.mergeA + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.traverseMaybeMissing $ combineMissing ca) + (Map.zipWithAMatched $ const (merge'' lca mode)) + (_children l) (_children r) + pure $ branch0 (_terms head0) (_types head0) children (_edits head0) + + combineMissing ca k cur = + case Map.lookup k (_children ca) of + Nothing -> pure $ Just cur + Just old -> do + nw <- merge'' lca mode (cons empty0 old) cur + if isEmpty0 $ head nw + then pure Nothing + else pure $ Just nw + + apply :: Branch0 m -> BranchDiff -> m (Branch0 m) + apply b0 BranchDiff {..} = do + patches <- sequenceA + $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches + let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) + makePatch Patch.PatchDiff {..} = + let p = Patch.Patch _addedTermEdits _addedTypeEdits + in (H.accumulate' p, pure p) + pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) + (Star3.difference (_types b0) removedTypes <> addedTypes) + (_children b0) + (patches <> newPatches) + patchMerge mhp Patch.PatchDiff {..} = Just $ do + (_, mp) <- mhp + p <- mp + let np = Patch.Patch + { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits + <> _addedTermEdits + , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits + <> _addedTypeEdits + } + pure (H.accumulate' np, pure np) + +-- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` +-- -- It's defined as: lca b1 b2 == Just b1 +-- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) +-- -> Branch m -> Branch m -> m Bool +-- before' lca (Branch x) (Branch y) = Causal.before' lca' x y +-- where +-- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) + +-- `before b1 b2` is true if `b2` incorporates all of `b1` +before :: Monad m => Branch m -> Branch m -> m Bool +before (Branch b1) (Branch b2) = Causal.before b1 b2 + +merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) + -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) +merge0 lca mode b1 b2 = do + c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) + e3 <- unionWithM g (_edits b1) (_edits b2) + pure $ branch0 (_terms b1 <> _terms b2) + (_types b1 <> _types b2) + c3 + e3 + where + g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) + g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) + g (_, m1) (_, m2) = do + e1 <- m1 + e2 <- m2 + let e3 = e1 <> e2 + pure (H.accumulate' e3, pure e3) + +pattern Hash h = Causal.RawHash h + +-- toList0 :: Branch0 m -> [(Path, Branch0 m)] +-- toList0 = go Path.empty where +-- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> +-- go (Path.snoc p seg) (head cb) )) + +-- printDebugPaths :: Branch m -> String +-- printDebugPaths = unlines . map show . Set.toList . debugPaths + +-- debugPaths :: Branch m -> Set (Path, Hash) +-- debugPaths = go Path.empty where +-- go p b = Set.insert (p, headHash b) . Set.unions $ +-- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] + +-- data Target = TargetType | TargetTerm | TargetBranch +-- deriving (Eq, Ord, Show) + +instance Eq (Branch0 m) where + a == b = view terms a == view terms b + && view types a == view types b + && view children a == view children b + && (fmap fst . view edits) a == (fmap fst . view edits) b + +-- data ForkFailure = SrcNotFound | DestExists + +-- -- consider delegating to Names.numHashChars when ready to implement? +-- -- are those enough? +-- -- could move this to a read-only field in Branch0 +-- -- could move a Names0 to a read-only field in Branch0 until it gets too big +-- numHashChars :: Branch m -> Int +-- numHashChars _b = 3 + +-- This type is a little ugly, so we wrap it up with a nice type alias for +-- use outside this module. +type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) + +-- boundedCache :: MonadIO m => Word -> m (Cache m2) +-- boundedCache = Cache.semispaceCache + +-- Can use `Cache.nullCache` to disable caching if needed +cachedRead :: forall m . MonadIO m + => Cache m + -> Causal.Deserialize m Raw Raw + -> (EditHash -> m Patch) + -> Hash + -> m (Branch m) +cachedRead cache deserializeRaw deserializeEdits h = + Branch <$> Causal.cachedRead cache d h + where + fromRaw :: Raw -> m (Branch0 m) + fromRaw Raw {..} = do + children <- traverse go _childrenR + edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash + pure $ branch0 _termsR _typesR children edits + go = cachedRead cache deserializeRaw deserializeEdits + d :: Causal.Deserialize m Raw (Branch0 m) + d h = deserializeRaw h >>= \case + RawOne raw -> RawOne <$> fromRaw raw + RawCons raw h -> flip RawCons h <$> fromRaw raw + RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw + +sync + :: Monad m + => (Hash -> m Bool) + -> Causal.Serialize m Raw Raw + -> (EditHash -> m Patch -> m ()) + -> Branch m + -> m () +sync exists serializeRaw serializeEdits b = do + _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty + -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." + pure () + +-- serialize a `Branch m` indexed by the hash of its corresponding Raw +sync' + :: forall m + . Monad m + => (Hash -> m Bool) + -> Causal.Serialize m Raw Raw + -> (EditHash -> m Patch -> m ()) + -> Branch m + -> StateT (Set Hash) m () +sync' exists serializeRaw serializeEdits b = Causal.sync exists + serialize0 + (view history b) + where + serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) + serialize0 h b0 = case b0 of + RawOne b0 -> do + writeB0 b0 + lift $ serializeRaw h $ RawOne (toRaw b0) + RawCons b0 ht -> do + writeB0 b0 + lift $ serializeRaw h $ RawCons (toRaw b0) ht + RawMerge b0 hs -> do + writeB0 b0 + lift $ serializeRaw h $ RawMerge (toRaw b0) hs + where + writeB0 :: Branch0 m -> StateT (Set Hash) m () + writeB0 b0 = do + for_ (view children b0) $ \c -> do + queued <- State.get + when (Set.notMember (headHash c) queued) $ + sync' exists serializeRaw serializeEdits c + for_ (view edits b0) (lift . uncurry serializeEdits) + + -- this has to serialize the branch0 and its descendants in the tree, + -- and then serialize the rest of the history of the branch as well + +toRaw :: Branch0 m -> Raw +toRaw Branch0 {..} = + Raw _terms _types (headHash <$> _children) (fst <$> _edits) + +toCausalRaw :: Branch m -> Causal.Raw Raw Raw +toCausalRaw = \case + Branch (Causal.One _h e) -> RawOne (toRaw e) + Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht + Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) + +-- -- copy a path to another path +-- fork +-- :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- fork src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> case setIfNotExists dest src' root of +-- Nothing -> Left DestExists +-- Just root' -> Right root' + +-- -- Move the node at src to dest. +-- -- It's okay if `dest` is inside `src`, just create empty levels. +-- -- Try not to `step` more than once at each node. +-- move :: Applicative m +-- => Path +-- -> Path +-- -> Branch m +-- -> Either ForkFailure (Branch m) +-- move src dest root = case getAt src root of +-- Nothing -> Left SrcNotFound +-- Just src' -> +-- -- make sure dest doesn't already exist +-- case getAt dest root of +-- Just _destExists -> Left DestExists +-- Nothing -> +-- -- find and update common ancestor of `src` and `dest`: +-- Right $ modifyAt ancestor go root +-- where +-- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest +-- go = deleteAt relSrc . setAt relDest src' + +-- setIfNotExists +-- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) +-- setIfNotExists dest b root = case getAt dest root of +-- Just _destExists -> Nothing +-- Nothing -> Just $ setAt dest b root + +-- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m +-- setAt path b = modifyAt path (const b) + +-- deleteAt :: Applicative m => Path -> Branch m -> Branch m +-- deleteAt path = setAt path empty + +-- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` +getAt :: Path + -> Branch m + -> Maybe (Branch m) +getAt path root = case Path.uncons path of + Nothing -> if isEmpty root then Nothing else Just root + Just (seg, path) -> case Map.lookup seg (_children $ head root) of + Just b -> getAt path b + Nothing -> Nothing + +getAt' :: Path -> Branch m -> Branch m +getAt' p b = fromMaybe empty $ getAt p b + +-- getAt0 :: Path -> Branch0 m -> Branch0 m +-- getAt0 p b = case Path.uncons p of +-- Nothing -> b +-- Just (seg, path) -> case Map.lookup seg (_children b) of +-- Just c -> getAt0 path (head c) +-- Nothing -> empty0 + +empty :: Branch m +empty = Branch $ Causal.one empty0 + +-- one :: Branch0 m -> Branch m +-- one = Branch . Causal.one + +empty0 :: Branch0 m +empty0 = + Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty + +isEmpty0 :: Branch0 m -> Bool +isEmpty0 = (== empty0) + +isEmpty :: Branch m -> Bool +isEmpty = (== empty) + +step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m +step f = \case + Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) + b -> over history (Causal.stepDistinct f) b + +-- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepM f = \case +-- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 +-- b -> mapMOf history (Causal.stepDistinctM f) b + +cons :: Applicative m => Branch0 m -> Branch m -> Branch m +cons = step . const + +-- isOne :: Branch m -> Bool +-- isOne (Branch Causal.One{}) = True +-- isOne _ = False + +-- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) +-- uncons (Branch b) = go <$> Causal.uncons b where +-- go = over (_Just . _2) Branch + +-- -- Modify the branch0 at the head of at `path` with `f`, +-- -- after creating it if necessary. Preserves history. +-- stepAt :: forall m. Applicative m +-- => Path +-- -> (Branch0 m -> Branch0 m) +-- -> Branch m -> Branch m +-- stepAt p f = modifyAt p g where +-- g :: Branch m -> Branch m +-- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b + +-- stepManyAt :: (Monad m, Foldable f) +-- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m +-- stepManyAt actions = step (stepManyAt0 actions) + +-- -- Modify the branch0 at the head of at `path` with `f`, +-- -- after creating it if necessary. Preserves history. +-- stepAtM :: forall n m. (Functor n, Applicative m) +-- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepAtM p f = modifyAtM p g where +-- g :: Branch m -> n (Branch m) +-- g (Branch b) = do +-- b0' <- f (Causal.head b) +-- pure $ Branch . Causal.consDistinct b0' $ b + +-- stepManyAtM :: (Monad m, Monad n, Foldable f) +-- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) +-- stepManyAtM actions = stepM (stepManyAt0M actions) + +-- -- starting at the leaves, apply `f` to every level of the branch. +-- stepEverywhere +-- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) +-- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) +-- where children = fmap (step $ stepEverywhere f) _children + +-- -- Creates a function to fix up the children field._1 +-- -- If the action emptied a child, then remove the mapping, +-- -- otherwise update it. +-- -- Todo: Fix this in hashing & serialization instead of here? +-- getChildBranch :: NameSegment -> Branch0 m -> Branch m +-- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) + +-- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m +-- setChildBranch seg b = over children (updateChildren seg b) + +-- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch +-- getPatch seg b = case Map.lookup seg (_edits b) of +-- Nothing -> pure Patch.empty +-- Just (_, p) -> p + +-- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) +-- getMaybePatch seg b = case Map.lookup seg (_edits b) of +-- Nothing -> pure Nothing +-- Just (_, p) -> Just <$> p + +-- modifyPatches +-- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) +-- modifyPatches seg f = mapMOf edits update +-- where +-- update m = do +-- p' <- case Map.lookup seg m of +-- Nothing -> pure $ f Patch.empty +-- Just (_, p) -> f <$> p +-- let h = H.accumulate' p' +-- pure $ Map.insert seg (h, pure p') m + +-- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m +-- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) + +-- deletePatch :: NameSegment -> Branch0 m -> Branch0 m +-- deletePatch n = over edits (Map.delete n) + +-- updateChildren ::NameSegment +-- -> Branch m +-- -> Map NameSegment (Branch m) +-- -> Map NameSegment (Branch m) +-- updateChildren seg updatedChild = +-- if isEmpty updatedChild +-- then Map.delete seg +-- else Map.insert seg updatedChild + +-- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- Because it's a `Branch`, it overwrites the history at `path`. +-- modifyAt :: Applicative m +-- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m +-- modifyAt path f = runIdentity . modifyAtM path (pure . f) + +-- -- Modify the Branch at `path` with `f`, after creating it if necessary. +-- -- Because it's a `Branch`, it overwrites the history at `path`. +-- modifyAtM +-- :: forall n m +-- . Functor n +-- => Applicative m -- because `Causal.cons` uses `pure` +-- => Path +-- -> (Branch m -> n (Branch m)) +-- -> Branch m +-- -> n (Branch m) +-- modifyAtM path f b = case Path.uncons path of +-- Nothing -> f b +-- Just (seg, path) -> do -- Functor +-- let child = getChildBranch seg (head b) +-- child' <- modifyAtM path f child +-- -- step the branch by updating its children according to fixup +-- pure $ step (setChildBranch seg child') b + +-- -- stepManyAt0 consolidates several changes into a single step +-- stepManyAt0 :: forall f m . (Monad m, Foldable f) +-- => f (Path, Branch0 m -> Branch0 m) +-- -> Branch0 m -> Branch0 m +-- stepManyAt0 actions = +-- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] + +-- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) +-- => f (Path, Branch0 m -> n (Branch0 m)) +-- -> Branch0 m -> n (Branch0 m) +-- stepManyAt0M actions b = go (toList actions) b where +-- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) +-- go actions b = let +-- -- combines the functions that apply to this level of the tree +-- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] + +-- -- groups the actions based on the child they apply to +-- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] +-- childActions = +-- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] + +-- -- alters the children of `b` based on the `childActions` map +-- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) +-- stepChildren children0 = foldM g children0 $ Map.toList childActions +-- where +-- g children (seg, actions) = do +-- -- Recursively applies the relevant actions to the child branch +-- -- The `findWithDefault` is important - it allows the stepManyAt +-- -- to create new children at paths that don't previously exist. +-- child <- stepM (go actions) (Map.findWithDefault empty seg children0) +-- pure $ updateChildren seg child children +-- in do +-- c2 <- stepChildren (view children b) +-- currentAction (set children c2 b) + +instance Hashable (Branch0 m) where + tokens b = + [ H.accumulateToken (_terms b) + , H.accumulateToken (_types b) + , H.accumulateToken (headHash <$> _children b) + , H.accumulateToken (fst <$> _edits b) + ] + +-- -- getLocalBranch :: Hash -> IO Branch +-- -- getGithubBranch :: RemotePath -> IO Branch +-- -- getLocalEdit :: GUID -> IO Patch + +-- -- todo: consider inlining these into Actions2 +-- addTermName +-- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- addTermName r new md = +-- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- addTypeName +-- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m +-- addTypeName r new md = +-- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) + +-- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m +-- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m + +-- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m +-- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) +-- = over terms (Star3.deletePrimaryD1 (r,n)) b +-- deleteTermName _ _ b = b + +-- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m +-- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) +-- = over types (Star3.deletePrimaryD1 (r,n)) b +-- deleteTypeName _ _ b = b + +-- namesDiff :: Branch m -> Branch m -> Names.Diff +-- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) + +lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) +lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b + +diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff +diff0 old new = do + newEdits <- sequenceA $ snd <$> _edits new + oldEdits <- sequenceA $ snd <$> _edits old + let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) + (Map.mapMissing $ \_ p -> Patch.diff mempty p) + (Map.zipWithMatched (const Patch.diff)) + newEdits + oldEdits + pure $ BranchDiff + { addedTerms = Star3.difference (_terms new) (_terms old) + , removedTerms = Star3.difference (_terms old) (_terms new) + , addedTypes = Star3.difference (_types new) (_types old) + , removedTypes = Star3.difference (_types old) (_types new) + , changedPatches = diffEdits + } + +transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n +transform f b = case _history b of + causal -> Branch . Causal.transform f $ transformB0s f causal + where + transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n + transformB0 f b = + b { _children = transform f <$> _children b + , _edits = second f <$> _edits b + } + + transformB0s :: Functor m => (forall a . m a -> n a) + -> Causal m Raw (Branch0 m) + -> Causal m Raw (Branch0 n) + transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) + +-- data BranchAttentions = BranchAttentions +-- { -- Patches that were edited on the right but entirely removed on the left. +-- removedPatchEdited :: [Name] +-- -- Patches that were edited on the left but entirely removed on the right. +-- , editedPatchRemoved :: [Name] +-- } + +-- instance Semigroup BranchAttentions where +-- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 +-- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) + +-- instance Monoid BranchAttentions where +-- mempty = BranchAttentions [] [] +-- mappend = (<>) + +-- data RefCollisions = +-- RefCollisions { termCollisions :: Relation Name Name +-- , typeCollisions :: Relation Name Name +-- } deriving (Eq, Show) + +-- instance Semigroup RefCollisions where +-- (<>) = mappend +-- instance Monoid RefCollisions where +-- mempty = RefCollisions mempty mempty +-- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) +-- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs index 94e837cc90..4edfb34f9c 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs @@ -2,27 +2,33 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} -module Unison.Codebase.FileCodebase.Branch.Dependencies where - -import Data.Set (Set) +module Unison.Codebase.FileCodebase.Branch.Dependencies + ( Branches, + Dependencies (..), + Dependencies' (..), + to', + fromRawCausal, + fromBranch, + ) +where import Data.Foldable (toList) -import qualified Data.Set as Set +import Data.Map (Map) import qualified Data.Map as Map -import Unison.Codebase.Branch (Branch(Branch), Branch0, EditHash) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import GHC.Generics (Generic) import Data.Monoid.Generic -import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Unison.Codebase.FileCodebase.Branch (Branch (Branch), Branch0, EditHash) +import qualified Unison.Codebase.Causal as Causal +import qualified Unison.Codebase.FileCodebase.Branch as Branch +import Unison.Codebase.FileCodebase.Patch (Patch) +import Unison.Codebase.FileCodebase.Reference (Reference (DerivedId)) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import Unison.Codebase.FileCodebase.Referent (Referent) +import qualified Unison.Codebase.FileCodebase.Referent as Referent import Unison.NameSegment (NameSegment) -import Unison.Referent (Referent) -import Unison.Codebase.Patch (Patch) -import qualified Unison.Util.Star3 as Star3 import qualified Unison.Util.Relation as R -import Unison.Reference (Reference(DerivedId)) - +import qualified Unison.Util.Star3 as Star3 type Branches m = [(Branch.Hash, Maybe (m (Branch m)))] data Dependencies = Dependencies @@ -45,7 +51,6 @@ data Dependencies' = Dependencies' deriving Semigroup via GenericSemigroup Dependencies' deriving Monoid via GenericMonoid Dependencies' - to' :: Dependencies -> Dependencies' to' Dependencies{..} = Dependencies' (toList patches) (toList terms) (toList decls) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs new file mode 100644 index 0000000000..743d5392b8 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.FileCodebase.Codebase + ( Codebase (..), + CodebasePath, + GetRootBranchError (..), + GitError (..), + GitFileCodebaseError (..), + SyncToDir, + ) +where + +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.FileCodebase.Branch (Branch) +import qualified Unison.Codebase.FileCodebase.Branch as Branch +import Unison.Codebase.FileCodebase.DataDeclaration (Decl) +import Unison.Codebase.FileCodebase.Patch (Patch) +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import Unison.Codebase.FileCodebase.Term (Term) +import Unison.Codebase.FileCodebase.Type (Type) +import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) +import qualified Unison.Codebase.Reflog as Reflog +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.SyncMode (SyncMode) +import Unison.CodebasePath (CodebasePath) +import Unison.Prelude +import Unison.ShortHash (ShortHash) +import qualified Unison.WatchKind as WK + +type SyncToDir m = + CodebasePath -> -- dest codebase + SyncMode -> + Branch m -> -- branch to sync to dest codebase + m () + +-- | Abstract interface to a user's codebase. +-- +-- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. +data Codebase m v a = Codebase + { getTerm :: Reference.Id -> m (Maybe (Term v a)), + getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)), + getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), + putTerm :: Reference.Id -> Term v a -> Type v a -> m (), + putTypeDeclaration :: Reference.Id -> Decl v a -> m (), + getRootBranch :: m (Either GetRootBranchError (Branch m)), + putRootBranch :: Branch m -> m (), + rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), + getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)), + putBranch :: Branch m -> m (), + branchExists :: Branch.Hash -> m Bool, + getPatch :: Branch.EditHash -> m (Maybe Patch), + putPatch :: Branch.EditHash -> Patch -> m (), + patchExists :: Branch.EditHash -> m Bool, + dependentsImpl :: Reference -> m (Set Reference.Id), + -- This copies all the dependencies of `b` from the specified Codebase into this one + syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + -- This copies all the dependencies of `b` from this Codebase + syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)), + pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()), + -- Watch expressions are part of the codebase, the `Reference.Id` is + -- the hash of the source of the watch expression, and the `Term v a` + -- is the evaluated result of the expression, decompiled to a term. + watches :: WK.WatchKind -> m [Reference.Id], + getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)), + putWatch :: WK.WatchKind -> Reference.Id -> Term v a -> m (), + clearWatches :: m (), + getReflog :: m [Reflog.Entry Branch.Hash], + appendReflog :: Text -> Branch m -> Branch m -> m (), + -- list of terms of the given type + termsOfTypeImpl :: Reference -> m (Set Referent.Id), + -- list of terms that mention the given type anywhere in their signature + termsMentioningTypeImpl :: Reference -> m (Set Referent.Id), + -- number of base58 characters needed to distinguish any two references in the codebase + hashLength :: m Int, + termReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + termReferentsByPrefix :: ShortHash -> m (Set Referent.Id), + branchHashLength :: m Int, + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash), + -- returns `Nothing` to not implemented, fallback to in-memory + -- also `Nothing` if no LCA + -- The result is undefined if the two hashes are not in the codebase. + -- Use `Codebase.lca` which wraps this in a nice API. + lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)), + -- `beforeImpl` returns `Nothing` if not implemented by the codebase + -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase + -- + -- Use `Codebase.before` which wraps this in a nice API. + beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) + } + +data GetRootBranchError + = NoRootBranch + | CouldntParseRootBranch FilePath + | CouldntLoadRootBranch Branch.Hash + deriving (Show) + +data GitError + = GitProtocolError GitProtocolError + | GitCodebaseError (GitCodebaseError Branch.Hash) + | GitFileCodebaseError GitFileCodebaseError + +data GitFileCodebaseError + = GitCouldntParseRootBranchHash ReadRepo String + deriving Show \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs index 12238dd737..39065a17b7 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs @@ -73,59 +73,58 @@ module Unison.Codebase.FileCodebase.Common import Unison.Prelude -import Control.Error (runExceptT, ExceptT(..)) -import Control.Lens (Lens, use, to, (%=)) -import Control.Monad.Catch (catch) -import Control.Monad.State (MonadState) +import Control.Error (ExceptT (..), runExceptT) +import Control.Lens (Lens, to, use, (%=)) +import Control.Monad.Catch (catch) +import Control.Monad.State (MonadState) import qualified Data.ByteString.Base16 as ByteString (decodeBase16, encodeBase16) -import qualified Data.Char as Char -import Data.List ( isPrefixOf ) -import qualified Data.Set as Set -import qualified Data.Text as Text -import UnliftIO.Directory ( createDirectoryIfMissing - , doesFileExist - , removeFile - , doesDirectoryExist, copyFile - ) -import UnliftIO.IO.File (writeBinaryFile) +import qualified Data.Char as Char +import Data.Either.Extra (maybeToEither) +import Data.List (isPrefixOf) +import qualified Data.Set as Set +import qualified Data.Text as Text import qualified System.Directory -import System.FilePath ( takeBaseName - , takeDirectory - , () - ) -import qualified Unison.Codebase as Codebase -import Unison.Codebase (CodebasePath) -import Unison.Codebase.Causal ( Causal - , RawHash(..) - ) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Branch ( Branch ) -import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.ShortBranchHash (ShortBranchHash(..)) -import qualified Unison.Codebase.ShortBranchHash as SBH +import System.FilePath (takeBaseName, takeDirectory, ()) +import U.Util.Timing (time) +import Unison.Codebase (CodebasePath) +import Unison.Codebase.Causal (Causal, RawHash (..)) +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.FileCodebase.Branch (Branch) +import qualified Unison.Codebase.FileCodebase.Branch as Branch +import qualified Unison.Codebase.FileCodebase.Codebase as Codebase +import qualified Unison.Codebase.FileCodebase.DataDeclaration as DD +import Unison.Codebase.FileCodebase.Patch (Patch (..)) +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import Unison.Codebase.FileCodebase.Referent (Referent) +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 +import Unison.Codebase.FileCodebase.Term (Term) +import qualified Unison.Codebase.FileCodebase.Term as Term +import Unison.Codebase.FileCodebase.Type (Type) +import qualified Unison.Codebase.FileCodebase.Type as Type import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.Codebase.SyncMode ( SyncMode ) -import Unison.Codebase.Patch ( Patch(..) ) -import qualified Unison.ConstructorType as CT -import qualified Unison.DataDeclaration as DD -import qualified Unison.Hash as Hash -import Unison.Parser ( Ann(External) ) -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import Unison.Referent ( Referent ) -import qualified Unison.Referent as Referent -import Unison.ShortHash (ShortHash) +import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) +import qualified Unison.Codebase.ShortBranchHash as SBH +import Unison.Codebase.SyncMode (SyncMode) +import qualified Unison.ConstructorType as CT +import qualified Unison.Hash as Hash +import Unison.Parser.Ann (Ann (External)) +import qualified Unison.Referent' as Referent +import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH -import Unison.Term ( Term ) -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import Unison.Var ( Var ) -import qualified Unison.UnisonFile as UF -import Unison.Util.Monoid (foldMapM) -import U.Util.Timing (time) -import Data.Either.Extra (maybeToEither) +import Unison.Util.Monoid (foldMapM) +import Unison.Var (Var) +import Unison.WatchKind (WatchKind) +import qualified Unison.WatchKind as WK +import UnliftIO.Directory + ( copyFile, + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + removeFile, + ) +import UnliftIO.IO.File (writeBinaryFile) data Err = InvalidBranchFile FilePath String @@ -178,11 +177,11 @@ dependentsDir root r = dependentsDir' root referenceToDir r dependentsDir' root = root codebasePath "dependents" watchesDir :: CodebasePath -> Text -> FilePath -watchesDir root UF.RegularWatch = +watchesDir root WK.RegularWatch = root codebasePath "watches" "_cache" watchesDir root kind = root codebasePath "watches" encodeFileName (Text.unpack kind) -watchPath :: CodebasePath -> UF.WatchKind -> Reference.Id -> FilePath +watchPath :: CodebasePath -> WatchKind -> Reference.Id -> FilePath watchPath root kind id = watchesDir root (Text.pack kind) componentIdToString id <> ".ub" @@ -511,7 +510,7 @@ getWatch :: (MonadIO m, Ord v) => S.Get v -> S.Get a -> CodebasePath - -> UF.WatchKind + -> WatchKind -> Reference.Id -> m (Maybe (Term v a)) getWatch getV getA path k id = do @@ -525,7 +524,7 @@ putWatch => S.Put v -> S.Put a -> CodebasePath - -> UF.WatchKind + -> WatchKind -> Reference.Id -> Term v a -> m () diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs new file mode 100644 index 0000000000..d2735323e1 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.Codebase.FileCodebase.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + Modifier(..), + asDataDecl, + constructorType, + constructorTypes, + declConstructorReferents, + declDependencies, + dependencies, + ) +where + +import Unison.Prelude + + +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import Unison.Codebase.FileCodebase.Type (Type) +import qualified Unison.Codebase.FileCodebase.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Referent' as Referent' +import Prelude hiding (cycle) + +type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) + +data DeclOrBuiltin v a = + Builtin CT.ConstructorType | Decl (Decl v a) + deriving (Eq, Show) + +asDataDecl :: Decl v a -> DataDeclaration v a +asDataDecl = either toDataDecl id + +declDependencies :: Ord v => Decl v a -> Set Reference +declDependencies = either (dependencies . toDataDecl) dependencies + +constructorType :: Decl v a -> CT.ConstructorType +constructorType = \case + Left{} -> CT.Effect + Right{} -> CT.Data + +data Modifier = Structural | Unique Text -- | Opaque (Set Reference) + deriving (Eq, Ord, Show) + +data DataDeclaration v a = DataDeclaration { + modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] +} deriving (Eq, Show, Functor) + +newtype EffectDeclaration v a = EffectDeclaration { + toDataDecl :: DataDeclaration v a +} deriving (Eq,Show,Functor) + +constructorTypes :: DataDeclaration v a -> [Type v a] +constructorTypes = (snd <$>) . constructors + +constructors :: DataDeclaration v a -> [(v, Type v a)] +constructors (DataDeclaration _ _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] + +-- This function is unsound, since the `rid` and the `decl` have to match. +-- It should probably be hashed directly from the Decl, once we have a +-- reliable way of doing that. —AI +declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] +declConstructorReferents rid decl = + [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] + where ct = constructorType decl + +constructorIds :: DataDeclaration v a -> [Int] +constructorIds dd = [0 .. length (constructors dd) - 1] + + +dependencies :: Ord v => DataDeclaration v a -> Set Reference +dependencies dd = + Set.unions (Type.dependencies <$> constructorTypes dd) + +data F a + = Type (Type.F a) + | LetRec [a] a + | Constructors [a] + | Modified Modifier a + deriving (Functor, Foldable, Show, Show1) + +instance Hashable1 F where + hash1 hashCycle hash e = + let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +instance Hashable.Hashable Modifier where + tokens Structural = [Hashable.Tag 0] + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs new file mode 100644 index 0000000000..6d8f591d32 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Unison.Codebase.FileCodebase.Init (Init(..), CreateCodebaseError(..), Pretty) where + +import Unison.Codebase.FileCodebase.Codebase (Codebase) +import Unison.CodebasePath (CodebasePath) +import qualified Unison.Util.Pretty as P + +type Pretty = P.Pretty P.ColorText + +data CreateCodebaseError + = CreateCodebaseAlreadyExists + | CreateCodebaseOther Pretty + +type DebugName = String + +data Init m v a = Init + { -- | open an existing codebase + openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + -- | create a new codebase + createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + -- | given a codebase root, and given that the codebase root may have other junk in it, + -- give the path to the "actual" files; e.g. what a forked transcript should clone. + codebasePath :: CodebasePath -> CodebasePath + } + diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs new file mode 100644 index 0000000000..76c23337ec --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Codebase.FileCodebase.LabeledDependency + ( derivedTerm + , derivedType + , termRef + , typeRef + , referent + , dataConstructor + , effectConstructor + , fold + , referents + , toReference + , LabeledDependency + , partition + ) where + +import Unison.Prelude hiding (fold) + +import qualified Data.Set as Set +import Unison.Codebase.FileCodebase.Reference (Id, Reference (DerivedId)) +import Unison.Codebase.FileCodebase.Referent (ConstructorId, Referent, pattern Con, pattern Ref) +import Unison.ConstructorType (ConstructorType (Data, Effect)) + +-- dumb constructor name is private +newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) + +derivedType, derivedTerm :: Id -> LabeledDependency +typeRef, termRef :: Reference -> LabeledDependency +referent :: Referent -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency + +derivedType = X . Left . DerivedId +derivedTerm = X . Right . Ref . DerivedId +typeRef = X . Left +termRef = X . Right . Ref +referent = X . Right +dataConstructor r cid = X . Right $ Con r cid Data +effectConstructor r cid = X . Right $ Con r cid Effect + +referents :: Foldable f => f Referent -> Set LabeledDependency +referents rs = Set.fromList (map referent $ toList rs) + +fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a +fold f g (X e) = either f g e + +partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) +partition = partitionEithers . map (\(X e) -> e) . toList + +-- | Left TypeRef | Right TermRef +toReference :: LabeledDependency -> Either Reference Reference +toReference = \case + X (Left r) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs new file mode 100644 index 0000000000..e6a58eb01a --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs @@ -0,0 +1,80 @@ +module Unison.Codebase.FileCodebase.Metadata where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Util.List as List +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as R +import qualified Unison.Util.Relation3 as R3 +import Unison.Util.Relation4 (Relation4) +import qualified Unison.Util.Relation4 as R4 +import Unison.Util.Star3 (Star3) +import qualified Unison.Util.Star3 as Star3 + +type Type = Reference +type Value = Reference + +-- keys can be terms or types +type Metadata = Map Type (Set Value) + +-- `a` is generally the type of references or hashes +-- `n` is generally the the type of name associated with the references +-- `Type` is the type of metadata. Duplicate info to speed up certain queries. +-- `(Type, Value)` is the metadata value itself along with its type. +type Star a n = Star3 a n Type (Type, Value) +type R4 a n = R4.Relation4 a n Type Value + +starToR4 :: (Ord r, Ord n) => Star r n -> Relation4 r n Type Value +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 -> R4 a n -> Bool +hasMetadataWithType' a t r = + fromMaybe False $ Set.member t . R3.d2s <$> (Map.lookup a $ R4.d1 r) + +hasMetadataWithType :: Ord a => a -> Type -> Star a n -> Bool +hasMetadataWithType a t = Set.member t . R.lookupDom a . Star3.d2 + +inserts :: (Ord a, Ord n) => [(a, Type, Value)] -> Star a n -> Star a n +inserts tups s = foldl' (flip insert) s tups + +insertWithMetadata + :: (Ord a, Ord n) => (a, Metadata) -> Star a n -> Star a n +insertWithMetadata (a, md) = + inserts [ (a, ty, v) | (ty, vs) <- Map.toList md, v <- toList vs ] + +insert :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n +insert (a, ty, v) = Star3.insertD23 (a, ty, (ty,v)) + +delete :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n +delete (a, ty, v) s = let + s' = Star3.deleteD3 (a, (ty,v)) s + -- if (ty,v) is the last metadata of type ty + -- we also delete (a, ty) from the d2 index + metadataByType = List.multimap (toList (R.lookupDom a (Star3.d3 s))) + in + case Map.lookup ty metadataByType of + Just vs | all (== v) vs -> Star3.deleteD2 (a, ty) s' + _ -> s' + +-- parallel composition - commutative and associative +merge :: Metadata -> Metadata -> Metadata +merge = Map.unionWith (<>) + +-- sequential composition, right-biased +append :: Metadata -> Metadata -> Metadata +append = Map.unionWith (flip const) + +empty :: Metadata +empty = mempty + +singleton :: Type -> Value -> Metadata +singleton ty v = Map.singleton ty (Set.singleton v) + +toRelation :: Star3 a n x y -> Relation a n +toRelation = Star3.d1 diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs new file mode 100644 index 0000000000..131be69311 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Unison.Codebase.FileCodebase.Patch where + +import Unison.Prelude hiding (empty) + +import Prelude hiding (head,read,subtract) + +import Control.Lens hiding (children, cons, transform) +import qualified Data.Set as Set +import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) +import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD +import Unison.Codebase.FileCodebase.Reference (Reference) +import Unison.Codebase.FileCodebase.TermEdit (TermEdit, Typing (Same)) +import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit +import Unison.Codebase.FileCodebase.TypeEdit (TypeEdit) +import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit +import Unison.Hashable (Hashable) +import qualified Unison.Hashable as H +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as R + +data Patch = Patch + { _termEdits :: Relation Reference TermEdit + , _typeEdits :: Relation Reference TypeEdit + } deriving (Eq, Ord, Show) + +data PatchDiff = PatchDiff + { _addedTermEdits :: Relation Reference TermEdit + , _addedTypeEdits :: Relation Reference TypeEdit + , _removedTermEdits :: Relation Reference TermEdit + , _removedTypeEdits :: Relation Reference TypeEdit + } deriving (Eq, Ord, Show) + +makeLenses ''Patch +makeLenses ''PatchDiff + +diff :: Patch -> Patch -> PatchDiff +diff new old = PatchDiff + { _addedTermEdits = R.difference (view termEdits new) (view termEdits old) + , _addedTypeEdits = R.difference (view typeEdits new) (view typeEdits old) + , _removedTypeEdits = R.difference (view typeEdits old) (view typeEdits new) + , _removedTermEdits = R.difference (view termEdits old) (view termEdits new) + } + +labeledDependencies :: Patch -> Set LabeledDependency +labeledDependencies Patch {..} = + Set.map LD.termRef (R.dom _termEdits) + <> Set.fromList + (fmap LD.termRef $ TermEdit.references =<< toList (R.ran _termEdits)) + <> Set.map LD.typeRef (R.dom _typeEdits) + <> Set.fromList + (fmap LD.typeRef $ TypeEdit.references =<< toList (R.ran _typeEdits)) + +empty :: Patch +empty = Patch mempty mempty + +isEmpty :: Patch -> Bool +isEmpty p = p == empty + +allReferences :: Patch -> Set Reference +allReferences p = typeReferences p <> termReferences p where + typeReferences p = Set.fromList + [ r | (old, TypeEdit.Replace new) <- R.toList (_typeEdits p) + , r <- [old, new] ] + termReferences p = Set.fromList + [ r | (old, TermEdit.Replace new _) <- R.toList (_termEdits p) + , r <- [old, new] ] + +-- | Returns the set of references which are the target of an arrow in the patch +allReferenceTargets :: Patch -> Set Reference +allReferenceTargets p = typeReferences p <> termReferences p where + typeReferences p = Set.fromList + [ new | (_, TypeEdit.Replace new) <- R.toList (_typeEdits p) ] + termReferences p = Set.fromList + [ new | (_, TermEdit.Replace new _) <- R.toList (_termEdits p) ] + +updateTerm :: (Reference -> Reference -> Typing) + -> Reference -> TermEdit -> Patch -> Patch +updateTerm typing r edit p = + -- get D ~= lookupRan r + -- for each d ∈ D, remove (d, r) and add (d, r') + -- add (r, r') and remove (r', r') + let deleteCycle = case edit of + TermEdit.Deprecate -> id + TermEdit.Replace r' _ -> R.delete r' (TermEdit.Replace r' Same) + edits' :: Relation Reference TermEdit + edits' = deleteCycle . R.insert r edit . R.map f $ _termEdits p + f (x, TermEdit.Replace y _) | y == r = case edit of + TermEdit.Replace r' _ -> (x, TermEdit.Replace r' (typing x r')) + TermEdit.Deprecate -> (x, TermEdit.Deprecate) + f p = p + in p { _termEdits = edits' } + +updateType :: Reference -> TypeEdit -> Patch -> Patch +updateType r edit p = + let deleteCycle = case edit of + TypeEdit.Deprecate -> id + TypeEdit.Replace r' -> R.delete r' (TypeEdit.Replace r') + edits' :: Relation Reference TypeEdit + edits' = deleteCycle . R.insert r edit . R.map f $ _typeEdits p + f (x, TypeEdit.Replace y) | y == r = case edit of + TypeEdit.Replace r' -> (x, TypeEdit.Replace r') + TypeEdit.Deprecate -> (x, TypeEdit.Deprecate) + f p = p + in p { _typeEdits = edits' } + +conflicts :: Patch -> Patch +conflicts Patch{..} = + Patch (R.filterManyDom _termEdits) (R.filterManyDom _typeEdits) + +instance Semigroup Patch where + a <> b = Patch (_termEdits a <> _termEdits b) + (_typeEdits a <> _typeEdits b) + +instance Monoid Patch where + mappend = (<>) + mempty = Patch mempty mempty + +instance Hashable Patch where + tokens e = [ H.Hashed (H.accumulate (H.tokens (_termEdits e))), + H.Hashed (H.accumulate (H.tokens (_typeEdits e))) ] + +instance Semigroup PatchDiff where + a <> b = PatchDiff + { _addedTermEdits = _addedTermEdits a <> _addedTermEdits b + , _addedTypeEdits = _addedTypeEdits a <> _addedTypeEdits b + , _removedTermEdits = _removedTermEdits a <> _removedTermEdits b + , _removedTypeEdits = _removedTypeEdits a <> _removedTypeEdits b + } + +instance Monoid PatchDiff where + mappend = (<>) + mempty = PatchDiff mempty mempty mempty mempty diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs new file mode 100644 index 0000000000..c25a42250c --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs @@ -0,0 +1,165 @@ +{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} + +module Unison.Codebase.FileCodebase.Pattern where + +import Unison.Prelude + +import Data.Foldable as Foldable hiding (foldMap') +import Data.List (intercalate) +import qualified Data.Set as Set +import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) +import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Type as Type +import qualified Unison.Hashable as H + +type ConstructorId = Int + +data Pattern loc + = Unbound loc + | Var loc + | Boolean loc !Bool + | Int loc !Int64 + | Nat loc !Word64 + | Float loc !Double + | Text loc !Text + | Char loc !Char + | Constructor loc !Reference !Int [Pattern loc] + | As loc (Pattern loc) + | EffectPure loc (Pattern loc) + | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | SequenceLiteral loc [Pattern loc] + | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + deriving (Ord,Generic,Functor,Foldable,Traversable) + +data SeqOp = Cons + | Snoc + | Concat + deriving (Eq, Show, Ord, Generic) + +instance H.Hashable SeqOp where + tokens Cons = [H.Tag 0] + tokens Snoc = [H.Tag 1] + tokens Concat = [H.Tag 2] + +instance Show (Pattern loc) where + show (Unbound _ ) = "Unbound" + show (Var _ ) = "Var" + show (Boolean _ x) = "Boolean " <> show x + show (Int _ x) = "Int " <> show x + show (Nat _ x) = "Nat " <> show x + show (Float _ x) = "Float " <> show x + show (Text _ t) = "Text " <> show t + show (Char _ c) = "Char " <> show c + show (Constructor _ r i ps) = + "Constructor " <> unwords [show r, show i, show ps] + show (As _ p) = "As " <> show p + show (EffectPure _ k) = "EffectPure " <> show k + show (EffectBind _ r i ps k) = + "EffectBind " <> unwords [show r, show i, show ps, show k] + show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) + show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt + +application :: Pattern loc -> Bool +application (Constructor _ _ _ (_ : _)) = True +application _ = False + +loc :: Pattern loc -> loc +loc p = head $ Foldable.toList p + +setLoc :: Pattern loc -> loc -> Pattern loc +setLoc p loc = case p of + EffectBind _ a b c d -> EffectBind loc a b c d + EffectPure _ a -> EffectPure loc a + As _ a -> As loc a + Constructor _ a b c -> Constructor loc a b c + SequenceLiteral _ ps -> SequenceLiteral loc ps + SequenceOp _ ph op pt -> SequenceOp loc ph op pt + x -> fmap (const loc) x + +instance H.Hashable (Pattern p) where + tokens (Unbound _) = [H.Tag 0] + tokens (Var _) = [H.Tag 1] + tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] + tokens (Int _ n) = H.Tag 3 : [H.Int n] + tokens (Nat _ n) = H.Tag 4 : [H.Nat n] + tokens (Float _ f) = H.Tag 5 : H.tokens f + tokens (Constructor _ r n args) = + [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] + tokens (EffectPure _ p) = H.Tag 7 : H.tokens p + tokens (EffectBind _ r n args k) = + [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] + tokens (As _ p) = H.Tag 9 : H.tokens p + tokens (Text _ t) = H.Tag 10 : H.tokens t + tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps + tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r + tokens (Char _ c) = H.Tag 13 : H.tokens c + +instance Eq (Pattern loc) where + Unbound _ == Unbound _ = True + Var _ == Var _ = True + Boolean _ b == Boolean _ b2 = b == b2 + Int _ n == Int _ m = n == m + Nat _ n == Nat _ m = n == m + Float _ f == Float _ g = f == g + Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs + EffectPure _ p == EffectPure _ q = p == q + EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 + As _ p == As _ q = p == q + Text _ t == Text _ t2 = t == t2 + SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 + SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 + _ == _ = False + +foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m +foldMap' f p = case p of + Unbound _ -> f p + Var _ -> f p + Boolean _ _ -> f p + Int _ _ -> f p + Nat _ _ -> f p + Float _ _ -> f p + Text _ _ -> f p + Char _ _ -> f p + Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps + As _ p' -> f p <> foldMap' f p' + EffectPure _ p' -> f p <> foldMap' f p' + EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' + SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps + SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 + +generalizedDependencies + :: Ord r + => (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Pattern loc + -> Set r +generalizedDependencies literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . foldMap' + (\case + Unbound _ -> mempty + Var _ -> mempty + As _ _ -> mempty + Constructor _ r cid _ -> [dataType r, dataConstructor r cid] + EffectPure _ _ -> [effectType Type.effectRef] + EffectBind _ r cid _ _ -> + [effectType Type.effectRef, effectType r, effectConstructor r cid] + SequenceLiteral _ _ -> [literalType Type.listRef] + SequenceOp {} -> [literalType Type.listRef] + Boolean _ _ -> [literalType Type.booleanRef] + Int _ _ -> [literalType Type.intRef] + Nat _ _ -> [literalType Type.natRef] + Float _ _ -> [literalType Type.floatRef] + Text _ _ -> [literalType Type.textRef] + Char _ _ -> [literalType Type.charRef] + ) + +labeledDependencies :: Pattern loc -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs new file mode 100644 index 0000000000..a3c44cfccb --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.FileCodebase.Reference + (Reference, + pattern Builtin, + pattern Derived, + pattern DerivedId, + Id(..), + Pos, + Size, + derivedBase32Hex, + Component, members, + components, + groupByComponent, + componentFor, + unsafeFromText, + idFromText, + isPrefixOf, + fromShortHash, + fromText, + readSuffix, + showShort, + showSuffix, + toId, + toText, + unsafeId, + toShortHash, + idToShortHash) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Unison.Hash as H +import Unison.Hashable as Hashable +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import Data.Char (isDigit) + +-- | Either a builtin or a user defined (hashed) top-level declaration. +-- +-- Used for both terms and types. Doesn't distinguish between them. +-- +-- Other used defined things like local variables don't get @Reference@s. +data Reference + = Builtin Text.Text + -- `Derived` can be part of a strongly connected component. + -- The `Pos` refers to a particular element of the component + -- and the `Size` is the number of elements in the component. + -- Using an ugly name so no one tempted to use this + | DerivedId Id deriving (Eq,Ord,Generic) + +pattern Derived :: H.Hash -> Pos -> Size -> Reference +pattern Derived h i n = DerivedId (Id h i n) + +{-# COMPLETE Builtin, Derived #-} + +-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. +data Id = Id H.Hash Pos Size deriving (Generic) + +unsafeId :: Reference -> Id +unsafeId (Builtin b) = + error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." +unsafeId (DerivedId x) = x + +idToShortHash :: Id -> ShortHash +idToShortHash = toShortHash . DerivedId + +-- todo: move these to ShortHash module? +-- but Show Reference currently depends on SH +toShortHash :: Reference -> ShortHash +toShortHash (Builtin b) = SH.Builtin b +toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing +toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing + where + -- todo: remove `n` parameter; must also update readSuffix + index = Just $ showSuffix i n + +-- toShortHash . fromJust . fromShortHash == id and +-- fromJust . fromShortHash . toShortHash == id +-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it +-- may not be possible to base32Hex decode them. These will return Nothing. +-- Also, ShortHashes that include constructor ids will return Nothing; +-- try Referent.fromShortHash +fromShortHash :: ShortHash -> Maybe Reference +fromShortHash (SH.Builtin b) = Just (Builtin b) +fromShortHash (SH.ShortHash prefix cycle Nothing) = do + h <- H.fromBase32Hex prefix + case cycle of + Nothing -> Just (Derived h 0 1) + Just t -> case Text.splitOn "c" t of + [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) + _ -> Nothing +fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing + +-- (3,10) encoded as "3c10" +-- (0,93) encoded as "0c93" +showSuffix :: Pos -> Size -> Text +showSuffix i n = Text.pack $ show i <> "c" <> show n + +-- todo: don't read or return size; must also update showSuffix and fromText +readSuffix :: Text -> Either String (Pos, Size) +readSuffix t = case Text.breakOn "c" t of + (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> + Right (read (Text.unpack pos), read (Text.unpack size)) + _ -> Left "suffix decoding error" + +isPrefixOf :: ShortHash -> Reference -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +toText :: Reference -> Text +toText = SH.toText . toShortHash + +showShort :: Int -> Reference -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +type Pos = Word64 +type Size = Word64 + +newtype Component = Component { members :: Set Reference } + +-- Gives the component (dependency cycle) that the reference is a part of +componentFor :: Reference -> Component +componentFor b@Builtin {} = Component (Set.singleton b) +componentFor (Derived h _ n) = + Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] + +derivedBase32Hex :: Text -> Pos -> Size -> Reference +derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) + where + msg = error $ "Reference.derivedBase32Hex " <> show h + h = H.fromBase32Hex b32Hex + +unsafeFromText :: Text -> Reference +unsafeFromText = either error id . fromText + +idFromText :: Text -> Maybe Id +idFromText s = case fromText s of + Left _ -> Nothing + Right (Builtin _) -> Nothing + Right (DerivedId id) -> pure id + +toId :: Reference -> Maybe Id +toId (DerivedId id) = Just id +toId Builtin{} = Nothing + +-- examples: +-- `##Text.take` — builtins don’t have cycles +-- `#2tWjVAuc7` — derived, no cycle +-- `#y9ycWkiC1.y9` — derived, part of cycle +-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. +fromText :: Text -> Either String Reference +fromText t = case Text.split (=='#') t of + [_, "", b] -> Right (Builtin b) + [_, h] -> case Text.split (=='.') h of + [hash] -> Right (derivedBase32Hex hash 0 1) + [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix + _ -> bail + _ -> bail + where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t + +component :: H.Hash -> [k] -> [(k, Id)] +component h ks = let + size = fromIntegral (length ks) + in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] + +components :: [(H.Hash, [k])] -> [(k, Id)] +components sccs = uncurry component =<< sccs + +groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] +groupByComponent refs = done $ foldl' insert Map.empty refs + where + insert m (k, r@(Derived h _ _)) = + Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) + insert m (k, r) = + Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) + done m = sortOn snd <$> toList m + +instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId +instance Show Reference where show = SH.toString . SH.take 5 . toShortHash + +instance Hashable.Hashable Reference where + tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] + tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] + +-- | Two references mustn't differ in cycle length only. +instance Eq Id where x == y = compare x y == EQ +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs new file mode 100644 index 0000000000..8a00aa385c --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs @@ -0,0 +1,21 @@ +module Unison.Codebase.FileCodebase.Reference.Util where + +import Unison.Prelude + +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import Unison.Hashable (Hashable1) +import Unison.ABT (Var) +import qualified Unison.ABT as ABT +import qualified Data.Map as Map + +hashComponents :: + (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) + => (Reference.Id -> ABT.Term f v ()) + -> Map v (ABT.Term f v a) + -> Map v (Reference.Id, ABT.Term f v a) +hashComponents embedRef tms = + Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) + + diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs new file mode 100644 index 0000000000..a022d3b4a5 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Codebase.FileCodebase.Referent where + +import Unison.Prelude +import Unison.Referent' ( Referent'(..), toReference' ) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as R +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH + +import Unison.ConstructorType (ConstructorType) +import qualified Unison.ConstructorType as CT + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. +type Referent = Referent' Reference +type ConstructorId = Int +pattern Ref :: Reference -> Referent +pattern Ref r = Ref' r +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent +pattern Con r i t = Con' r i t +{-# COMPLETE Ref, Con #-} + +-- | Cannot be a builtin. +type Id = Referent' R.Id + +-- referentToTerm moved to Term.fromReferent +-- termToReferent moved to Term.toReferent + +-- todo: move these to ShortHash module +toShortHash :: Referent -> ShortHash +toShortHash = \case + Ref r -> R.toShortHash r + Con r i _ -> patternShortHash r i + +toShortHashId :: Id -> ShortHash +toShortHashId = toShortHash . fromId + +-- also used by HashQualified.fromPattern +patternShortHash :: Reference -> ConstructorId -> ShortHash +patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } + +showShort :: Int -> Referent -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +toText :: Referent -> Text +toText = \case + Ref r -> R.toText r + Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) + +ctorTypeText :: CT.ConstructorType -> Text +ctorTypeText CT.Effect = EffectCtor +ctorTypeText CT.Data = DataCtor + +pattern EffectCtor = "a" +pattern DataCtor = "d" + +toString :: Referent -> String +toString = Text.unpack . toText + +isConstructor :: Referent -> Bool +isConstructor Con{} = True +isConstructor _ = False + +toTermReference :: Referent -> Maybe Reference +toTermReference = \case + Ref r -> Just r + _ -> Nothing + +toReference :: Referent -> Reference +toReference = toReference' + +fromId :: Id -> Referent +fromId = fmap R.DerivedId + +toTypeReference :: Referent -> Maybe Reference +toTypeReference = \case + Con r _i _t -> Just r + _ -> Nothing + +isPrefixOf :: ShortHash -> Referent -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +unsafeFromText :: Text -> Referent +unsafeFromText = fromMaybe (error "invalid referent") . fromText + +-- #abc[.xy][#cid] +fromText :: Text -> Maybe Referent +fromText t = either (const Nothing) Just $ + -- if the string has just one hash at the start, it's just a reference + if Text.length refPart == 1 then + Ref <$> R.fromText t + else if Text.all Char.isDigit cidPart then do + r <- R.fromText (Text.dropEnd 1 refPart) + ctorType <- ctorType + let cid = read (Text.unpack cidPart) + pure $ Con r cid ctorType + else + Left ("invalid constructor id: " <> Text.unpack cidPart) + where + ctorType = case Text.take 1 cidPart' of + EffectCtor -> Right CT.Effect + DataCtor -> Right CT.Data + _otherwise -> + Left ("invalid constructor type (expected '" + <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') + refPart = Text.dropWhileEnd (/= '#') t + cidPart' = Text.takeWhileEnd (/= '#') t + cidPart = Text.drop 1 cidPart' + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct + diff --git a/parser-typechecker/src/Unison/Codebase/Serialization/V1.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs similarity index 84% rename from parser-typechecker/src/Unison/Codebase/Serialization/V1.hs rename to parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs index 7793eff071..d4b33ad9c4 100644 --- a/parser-typechecker/src/Unison/Codebase/Serialization/V1.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs @@ -1,77 +1,81 @@ {-# LANGUAGE Strict #-} {-# LANGUAGE RankNTypes #-} -module Unison.Codebase.Serialization.V1 where +module Unison.Codebase.FileCodebase.Serialization.V1 + ( formatSymbol, + getBranchDependencies, + getCausal0, + getRawBranch, + getEdits, + putRawCausal, + putRawBranch, + putEdits, + getTerm, + getType, + putTerm, + putType, + getEither, + getEffectDeclaration, + getDataDeclaration, + putEither, + putEffectDeclaration, + putDataDeclaration, + ) +where import Unison.Prelude import Prelude hiding (getChar, putChar) -import Basement.Block (Block) - --- import qualified Data.Text as Text -import qualified Unison.Pattern as Pattern -import Unison.Pattern ( Pattern - , SeqOp - ) -import Data.Bits ( Bits ) -import Data.Bytes.Get as Ser -import Data.Bytes.Put as Ser -import Data.Bytes.Serial ( serialize - , deserialize - , serializeBE - , deserializeBE - ) -import qualified Data.ByteArray as BA -import Data.Bytes.Signed ( Unsigned ) -import Data.Bytes.VarInt ( VarInt(..) ) -import qualified Data.Map as Map -import Data.List ( elemIndex - ) -import qualified Unison.Codebase.Branch as Branch +import Data.Bits (Bits) +import qualified Data.ByteString as B +import Data.Bytes.Get as Ser +import Data.Bytes.Put as Ser +import Data.Bytes.Serial (deserialize, deserializeBE, serialize, serializeBE) +import Data.Bytes.Signed (Unsigned) +import Data.Bytes.VarInt (VarInt (..)) +import Data.List (elemIndex) +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import qualified Unison.Codebase.FileCodebase.Branch as Branch +import Unison.Codebase.Causal (Raw (..), RawHash (..), unRawHash) +import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import Unison.Codebase.Causal ( Raw(..) - , RawHash(..) - , unRawHash - ) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.Metadata as Metadata -import Unison.NameSegment as NameSegment -import Unison.Codebase.Patch ( Patch(..) ) -import qualified Unison.Codebase.Patch as Patch -import Unison.Codebase.TermEdit ( TermEdit ) -import Unison.Codebase.TypeEdit ( TypeEdit ) -import Unison.Hash ( Hash ) -import Unison.Kind ( Kind ) -import Unison.Reference ( Reference ) -import Unison.Symbol ( Symbol(..) ) -import Unison.Term ( Term ) -import qualified Data.ByteString as B -import qualified Data.Sequence as Sequence -import qualified Data.Set as Set -import qualified Unison.ABT as ABT -import qualified Unison.Codebase.TermEdit as TermEdit -import qualified Unison.Codebase.TypeEdit as TypeEdit +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import Unison.Codebase.FileCodebase.Referent (Referent) +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import Unison.Codebase.FileCodebase.Term (Term) +import qualified Unison.Codebase.FileCodebase.Term as Term +import Unison.Codebase.FileCodebase.Type (Type) +import qualified Unison.Codebase.FileCodebase.Type as Type +import qualified Unison.Codebase.FileCodebase.Metadata as Metadata +import Unison.Codebase.FileCodebase.Patch (Patch (..)) +import qualified Unison.Codebase.FileCodebase.Patch as Patch import qualified Unison.Codebase.Serialization as S -import qualified Unison.Hash as Hash -import qualified Unison.Kind as Kind -import qualified Unison.Reference as Reference -import Unison.Referent (Referent) -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import qualified Unison.Type as Type -import qualified Unison.Util.Bytes as Bytes -import Unison.Util.Star3 ( Star3 ) -import qualified Unison.Util.Star3 as Star3 -import Unison.Util.Relation ( Relation ) -import qualified Unison.Util.Relation as Relation -import qualified Unison.DataDeclaration as DataDeclaration -import Unison.DataDeclaration ( DataDeclaration - , EffectDeclaration - ) -import qualified Unison.Var as Var -import qualified Unison.ConstructorType as CT -import Unison.Type (Type) +import Unison.Codebase.FileCodebase.TermEdit (TermEdit) +import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit +import Unison.Codebase.FileCodebase.TypeEdit (TypeEdit) +import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit +import qualified Unison.ConstructorType as CT +import Unison.Codebase.FileCodebase.DataDeclaration (DataDeclaration, EffectDeclaration) +import qualified Unison.Codebase.FileCodebase.DataDeclaration as DataDeclaration +import Unison.Hash (Hash) +import qualified Unison.Hash as Hash +import Unison.Kind (Kind) +import qualified Unison.Kind as Kind +import Unison.NameSegment (NameSegment (NameSegment)) +import qualified Unison.NameSegment as NameSegment +import Unison.Codebase.FileCodebase.Pattern (Pattern, SeqOp) +import qualified Unison.Codebase.FileCodebase.Pattern as Pattern +import Unison.Symbol (Symbol (..)) +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as Relation +import Unison.Util.Star3 (Star3) +import qualified Unison.Util.Star3 as Star3 +import qualified Unison.Var as Var -- ABOUT THIS FORMAT: -- @@ -294,20 +298,6 @@ putFoldable putA as = do putLength (length as) traverse_ putA as - --- putFoldableN --- :: forall f m n a --- . (Traversable f, MonadPut m, Applicative n) --- => f a --- -> (a -> n (m ())) --- -> n (m ()) --- putFoldableN as putAn = --- pure (putLength @m (length as)) *> (fmap sequence_ $ traverse putAn as) - -getFolded :: MonadGet m => (b -> a -> b) -> b -> m a -> m b -getFolded f z a = - foldl' f z <$> getList a - getList :: MonadGet m => m a -> m [a] getList a = getLength >>= (`replicateM` a) @@ -570,14 +560,6 @@ getTerm getVar getA = getABT getVar getA go where putPair :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a,b) -> m () putPair putA putB (a,b) = putA a *> putB b -putPair'' - :: (MonadPut m, Monad n) - => (a -> m ()) - -> (b -> n (m ())) - -> (a, b) - -> n (m ()) -putPair'' putA putBn (a, b) = pure (putA a) *> putBn b - getPair :: MonadGet m => m a -> m b -> m (a,b) getPair = liftA2 (,) @@ -669,12 +651,6 @@ putBranchStar putA putN = getBranchStar :: (Ord a, Ord n, MonadGet m) => m a -> m n -> m (Branch.Star a n) getBranchStar getA getN = getStar3 getA getN getMetadataType (getPair getMetadataType getMetadataValue) -putLink :: MonadPut m => (Hash, mb) -> m () -putLink (h, _) = do - -- 0 means local; later we may have remote links with other ids - putWord8 0 - putHash h - putChar :: MonadPut m => Char -> m () putChar = serialize . VarInt . fromEnum @@ -812,15 +788,3 @@ putEdits edits = getEdits :: MonadGet m => m Patch getEdits = Patch <$> getRelation getReference getTermEdit <*> getRelation getReference getTypeEdit - -putBytes :: MonadPut m => Bytes.Bytes -> m () -putBytes = putFoldable putBlock . Bytes.chunks - -putBlock :: MonadPut m => Bytes.View (Block Word8) -> m () -putBlock b = putLength (BA.length b) *> putByteString (BA.convert b) - -getBytes :: MonadGet m => m Bytes.Bytes -getBytes = Bytes.fromChunks <$> getList getBlock - -getBlock :: MonadGet m => m (Bytes.View (Block Word8)) -getBlock = getLength >>= fmap (Bytes.view . BA.convert) . getByteString diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs index e26ecbe719..591f1fd8c5 100644 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs @@ -11,38 +11,39 @@ module Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex (syncToDirectory) wh import Unison.Prelude -import qualified Data.Set as Set -import Control.Lens -import Control.Monad.State.Strict ( MonadState, evalStateT ) -import Control.Monad.Writer.Strict ( MonadWriter, execWriterT ) -import qualified Control.Monad.Writer.Strict as Writer -import UnliftIO.Directory ( doesFileExist ) -import Unison.Codebase ( CodebasePath ) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Branch ( Branch(..) ) -import qualified Unison.Codebase.Branch as Branch +import Control.Lens +import Control.Monad.State.Strict (MonadState, evalStateT) +import Control.Monad.Writer.Strict (MonadWriter, execWriterT) +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Set as Set +import U.Util.Timing (time) +import Unison.Codebase (CodebasePath) +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.FileCodebase.Branch (Branch (..)) +import qualified Unison.Codebase.FileCodebase.Branch as Branch import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import qualified Unison.Codebase.Patch as Patch +import qualified Unison.Codebase.FileCodebase.DataDeclaration as DD +import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD +import qualified Unison.Codebase.FileCodebase.Patch as Patch +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 +import qualified Unison.Codebase.FileCodebase.Term as Term +import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit +import Unison.Codebase.FileCodebase.Type (Type) +import qualified Unison.Codebase.FileCodebase.Type as Type +import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit import qualified Unison.Codebase.Serialization as S -import qualified Unison.Codebase.Serialization.V1 as V1 -import Unison.Codebase.SyncMode ( SyncMode ) -import qualified Unison.Codebase.SyncMode as SyncMode -import qualified Unison.Codebase.TermEdit as TermEdit -import qualified Unison.Codebase.TypeEdit as TypeEdit -import qualified Unison.DataDeclaration as DD -import qualified Unison.LabeledDependency as LD -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import Unison.Var ( Var ) -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Relation as Relation -import Unison.Util.Relation ( Relation ) -import Unison.Util.Monoid (foldMapM) -import U.Util.Timing (time) +import Unison.Codebase.SyncMode (SyncMode) +import qualified Unison.Codebase.SyncMode as SyncMode +import qualified Unison.Referent' as Referent +import Unison.Util.Monoid (foldMapM) +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as Relation +import Unison.Var (Var) +import qualified Unison.WatchKind as WK +import UnliftIO.Directory (doesFileExist) import Data.Monoid.Generic import Unison.Codebase.FileCodebase.Common @@ -273,9 +274,9 @@ syncToDirectory' getV getA srcPath destPath mode newRoot = Just typ -> do copyFileWithParents (termPath srcPath h) (termPath destPath h) copyFileWithParents (typePath srcPath h) (typePath destPath h) - whenM (doesFileExist $ watchPath srcPath UF.TestWatch h) $ - copyFileWithParents (watchPath srcPath UF.TestWatch h) - (watchPath destPath UF.TestWatch h) + whenM (doesFileExist $ watchPath srcPath WK.TestWatch h) $ + copyFileWithParents (watchPath srcPath WK.TestWatch h) + (watchPath destPath WK.TestWatch h) let typeDeps' = toList (Type.dependencies typ) let typeForIndexing = Type.removeAllEffectVars typ let typeReference = Type.toReference typeForIndexing diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs new file mode 100644 index 0000000000..cd3cad9405 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs @@ -0,0 +1,1120 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.FileCodebase.Term where + +import Unison.Prelude + +import Prelude hiding (and,or) +import Control.Monad.State (evalState) +import qualified Control.Monad.Writer.Strict as Writer +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Sequence as Sequence +import Prelude.Extras (Eq1(..), Show1(..)) +import Text.Show +import qualified Unison.ABT as ABT +import qualified Unison.Blank as B +import qualified Unison.Hash as Hash +import Unison.Hashable (Hashable1, accumulateToken) +import qualified Unison.Hashable as Hashable +import Unison.Codebase.FileCodebase.Pattern (Pattern) +import qualified Unison.Codebase.FileCodebase.Pattern as Pattern +import Unison.Codebase.FileCodebase.Reference (Reference, pattern Builtin) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Reference.Util as ReferenceUtil +import Unison.Codebase.FileCodebase.Referent (Referent) +import qualified Unison.Codebase.FileCodebase.Referent as Referent +import Unison.Codebase.FileCodebase.Type (Type) +import qualified Unison.Codebase.FileCodebase.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Util.List (multimap) +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unsafe.Coerce +import Unison.Symbol (Symbol) +import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD +import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) + +-- This gets reexported; should maybe live somewhere other than Pattern, though. +type ConstructorId = Pattern.ConstructorId + +data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a + deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) + +-- | Base functor for terms in the Unison language +-- We need `typeVar` because the term and type variables may differ. +data F typeVar typeAnn patternAnn a + = Int Int64 + | Nat Word64 + | Float Double + | Boolean Bool + | Text Text + | Char Char + | Blank (B.Blank typeAnn) + | Ref Reference + -- First argument identifies the data type, + -- second argument identifies the constructor + | Constructor Reference ConstructorId + | Request Reference ConstructorId + | Handle a a + | App a a + | Ann a (Type typeVar typeAnn) + | List (Seq a) + | If a a a + | And a a + | Or a a + | Lam a + -- Note: let rec blocks have an outer ABT.Cycle which introduces as many + -- variables as there are bindings + | LetRec IsTop [a] a + -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + | Let IsTop a a + -- Pattern matching / eliminating data types, example: + -- case x of + -- Just n -> rhs1 + -- Nothing -> rhs2 + -- + -- translates to + -- + -- Match x + -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- , (Constructor 1 [], rhs2) ] + | Match a [MatchCase patternAnn a] + | TermLink Referent + | TypeLink Reference + deriving (Foldable,Functor,Generic,Generic1,Traversable) + +type IsTop = Bool + +-- | Like `Term v`, but with an annotation of type `a` at every level in the tree +type Term v a = Term2 v a a v a +-- | Allow type variables and term variables to differ +type Term' vt v a = Term2 vt a a v a +-- | Allow type variables, term variables, type annotations and term annotations +-- to all differ +type Term2 vt at ap v a = ABT.Term (F vt at ap) v a +-- | Like `Term v a`, but with only () for type and pattern annotations. +type Term3 v a = Term2 v () () v a + +-- | Terms are represented as ABTs over the base functor F, with variables in `v` +type Term0 v = Term v () +-- | Terms with type variables in `vt`, and term variables in `v` +type Term0' vt v = Term' vt v () + +-- Prepare a term for type-directed name resolution by replacing +-- any remaining free variables with blanks to be resolved by TDNR +prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b +prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t + where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = + Just $ resolve (a, bound) a (Text.unpack $ Var.name v) + f _ = Nothing + +amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 +amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) + +patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a +patternMap f = go where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ + MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) + -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a +vmap f = ABT.vmap f . typeMap (ABT.vmap f) + +vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a +vtmap f = typeMap (ABT.vmap f) + +typeMap + :: Ord vt2 + => (Type vt at -> Type vt2 at2) + -> Term2 vt at ap v a + -> Term2 vt2 at2 ap v a +typeMap f = go + where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) + -- Safe since `Ann` is only ctor that has embedded `Type v` arg + -- otherwise we'd have to manually match on every non-`Ann` ctor + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +extraMap' + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> Term2 vt at ap v a + -> Term2 vt' at' ap' v a +extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) + +extraMap + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> F vt at ap a + -> F vt' at' ap' a +extraMap vtf atf apf = \case + Int x -> Int x + Nat x -> Nat x + Float x -> Float x + Boolean x -> Boolean x + Text x -> Text x + Char x -> Char x + Blank x -> Blank (fmap atf x) + Ref x -> Ref x + Constructor x y -> Constructor x y + Request x y -> Request x y + Handle x y -> Handle x y + App x y -> App x y + Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) + List x -> List x + If x y z -> If x y z + And x y -> And x y + Or x y -> Or x y + Lam x -> Lam x + LetRec x y z -> LetRec x y z + Let x y z -> Let x y z + Match tm l -> Match tm (map (matchCaseExtraMap apf) l) + TermLink r -> TermLink r + TypeLink r -> TypeLink r + +matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a +matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y + +unannotate + :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v +unannotate = go + where + go :: Term2 vt at ap v a -> Term0' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v ) = ABT.var v + go (ABT.Tm' f ) = case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + +wrapV :: Ord v => Term v a -> Term (ABT.V v) a +wrapV = vmap ABT.Bound + +-- | All variables mentioned in the given term. +-- Includes both term and type variables, both free and bound. +allVars :: Ord v => Term v a -> Set v +allVars tm = Set.fromList $ + ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] + where + allTypes tm = case tm of + Ann' e tp -> tp : allTypes e + _ -> foldMap allTypes $ ABT.out tm + +freeVars :: Term' vt v a -> Set v +freeVars = ABT.freeVars + +freeTypeVars :: Ord vt => Term' vt v a -> Set vt +freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t + +freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] +freeTypeVarAnnotations e = multimap $ go Set.empty e where + go bound tm = case tm of + Var' _ -> mempty + Ann' e (Type.stripIntroOuters -> t1) -> let + bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs + _ -> bound + in go bound' e <> ABT.freeVarOccurrences bound t1 + ABT.Tm' f -> foldMap (go bound) f + (ABT.out -> ABT.Abs _ body) -> go bound body + (ABT.out -> ABT.Cycle body) -> go bound body + _ -> error "unpossible" + +substTypeVars :: (Ord v, Var vt) + => [(vt, Type vt b)] + -> Term' vt v a + -> Term' vt v a +substTypeVars subs e = foldl' go e subs where + go e (vt, t) = substTypeVar vt t e + +-- Capture-avoiding substitution of a type variable inside a term. This +-- will replace that type variable wherever it appears in type signatures of +-- the term, avoiding capture by renaming ∀-binders. +substTypeVar + :: (Ord v, ABT.Var vt) + => vt + -> Type vt b + -> Term' vt v a + -> Term' vt v a +substTypeVar vt ty = go Set.empty where + go bound tm | Set.member vt bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where + fvs = ABT.freeVars ty + -- if the ∀ introduces a variable, v, which is free in `ty`, we pick a new + -- variable name for v which is unique, v', and rename v to v' in e. + uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let + v = ABT.variable body + v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v + t2 = ABT.bindInheritAnnotation body (Type.var() v2) + in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 + uncapture vs e t0 = let + t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a +renameTypeVar old new = go Set.empty where + go bound tm | Set.member old bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> let + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.rename old new (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- Converts free variables to bound variables using forall or introOuter. Example: +-- +-- foo : x -> x +-- foo a = +-- r : x +-- r = a +-- r +-- +-- This becomes: +-- +-- foo : ∀ x . x -> x +-- foo a = +-- r : outer x . x -- FYI, not valid syntax +-- r = a +-- r +-- +-- More specifically: in the expression `e : t`, unbound lowercase variables in `t` +-- are bound with foralls, and any ∀-quantified type variables are made bound in +-- `e` and its subexpressions. The result is a term with no lowercase free +-- variables in any of its type signatures, with outer references represented +-- with explicit `introOuter` binders. The resulting term may have uppercase +-- free variables that are still unbound. +generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a +generalizeTypeSignatures = go Set.empty where + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e (Type.generalizeLowercase bound -> t) -> let + bound' = case Type.unForalls t of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + in ann loc (go bound' e) (Type.freeVarsToOuters bound t) + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- nicer pattern syntax + +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst +pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) +pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) +pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) +pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) +pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) +pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) +pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) +pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) +pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) +pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) +pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) +pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) +pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) +pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) +pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) +pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) +pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) +pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) +pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) +pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) +pattern Apps' f args <- (unApps -> Just (f, args)) +-- begin pretty-printer helper patterns +pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) +pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) +pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) +pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +-- end pretty-printer helper patterns +pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) +pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) +pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) + +pattern Delay' body <- (unDelay -> Just body) +unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) +unDelay tm = case ABT.out tm of + ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) + | Set.notMember v (ABT.freeVars body) + -> Just body + _ -> Nothing + +pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) +pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) +pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) +pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) +pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) +pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) +pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) +pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) +pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) +pattern Lets' bs e <- (unLet -> Just (bs, e)) +pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) +pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) +pattern LetRec' subst <- (unLetRec -> Just (_, subst)) +pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) +pattern LetRecNamedAnnotatedTop' top ann bs e <- + (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) + +fresh :: Var v => Term0 v -> v -> v +fresh = ABT.fresh + +-- some smart constructors + +var :: a -> v -> Term2 vt at ap v a +var = ABT.annotatedVar + +var' :: Var v => Text -> Term0' vt v +var' = var() . Var.named + +ref :: Ord v => a -> Reference -> Term2 vt at ap v a +ref a r = ABT.tm' a (Ref r) + +pattern Referent' r <- (unReferent -> Just r) + +unReferent :: Term2 vt at ap v a -> Maybe Referent +unReferent (Ref' r) = Just $ Referent.Ref r +unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data +unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect +unReferent _ = Nothing + +refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Referent -> Term2 vt at ap v a +termLink a r = ABT.tm' a (TermLink r) + +typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a +typeLink a r = ABT.tm' a (TypeLink r) + +builtin :: Ord v => a -> Text -> Term2 vt at ap v a +builtin a n = ref a (Reference.Builtin n) + +float :: Ord v => a -> Double -> Term2 vt at ap v a +float a d = ABT.tm' a (Float d) + +boolean :: Ord v => a -> Bool -> Term2 vt at ap v a +boolean a b = ABT.tm' a (Boolean b) + +int :: Ord v => a -> Int64 -> Term2 vt at ap v a +int a d = ABT.tm' a (Int d) + +nat :: Ord v => a -> Word64 -> Term2 vt at ap v a +nat a d = ABT.tm' a (Nat d) + +text :: Ord v => a -> Text -> Term2 vt at ap v a +text a = ABT.tm' a . Text + +char :: Ord v => a -> Char -> Term2 vt at ap v a +char a = ABT.tm' a . Char + +watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a +watch a note e = + apps' (builtin a "Debug.watch") [text a (Text.pack note), e] + +watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a +watchMaybe Nothing e = e +watchMaybe (Just note) e = watch (ABT.annotation e) note e + +blank :: Ord v => a -> Term2 vt at ap v a +blank a = ABT.tm' a (Blank B.Blank) + +placeholder :: Ord v => a -> String -> Term2 vt a ap v a +placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) + +resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at +resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) + +constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +constructor a ref n = ABT.tm' a (Constructor ref n) + +request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +request a ref n = ABT.tm' a (Request ref n) + +-- todo: delete and rename app' to app +app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v +app_ f arg = ABT.tm (App f arg) + +app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +app a f arg = ABT.tm' a (App f arg) + +match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a +match a scrutinee branches = ABT.tm' a (Match scrutinee branches) + +handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +handle a h block = ABT.tm' a (Handle h block) + +and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +and a x y = ABT.tm' a (And x y) + +or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +or a x y = ABT.tm' a (Or x y) + +list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a +list a es = list' a (Sequence.fromList es) + +list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a +list' a es = ABT.tm' a (List es) + +apps + :: Ord v + => Term2 vt at ap v a + -> [(a, Term2 vt at ap v a)] + -> Term2 vt at ap v a +apps = foldl' (\f (a, t) -> app a f t) + +apps' + :: (Ord v, Semigroup a) + => Term2 vt at ap v a + -> [Term2 vt at ap v a] + -> Term2 vt at ap v a +apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) + +iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +iff a cond t f = ABT.tm' a (If cond t f) + +ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v +ann_ e t = ABT.tm (Ann e t) + +ann :: Ord v + => a + -> Term2 vt at ap v a + -> Type vt at + -> Term2 vt at ap v a +ann a e t = ABT.tm' a (Ann e t) + +-- arya: are we sure we want the two annotations to be the same? +lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a +lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) + +delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a +delay a body = + ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) + +lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam'' vs body = foldr (uncurry lam) body vs + +isLam :: Term2 vt at ap v a -> Bool +isLam t = arity t > 0 + +arity :: Term2 vt at ap v a -> Int +arity (LamNamed' _ body) = 1 + arity body +arity (Ann' e _) = arity e +arity _ = 0 + +unLetRecNamedAnnotated + :: Term' vt v a + -> Maybe + (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) +unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = + Just (isTop, ann, avs `zip` bs, e) +unLetRecNamedAnnotated _ = Nothing + +letRec' + :: (Ord v, Monoid a) + => Bool + -> [(v, Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec' isTop bindings body = + letRec isTop + (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) + [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] + body + +-- Prepend a binding to form a (bigger) let rec. Useful when +-- building up a block incrementally using a right fold. +-- +-- For example: +-- consLetRec (x = 42) "hi" +-- => +-- let rec x = 42 in "hi" +-- +-- consLetRec (x = 42) (let rec y = "hi" in (x,y)) +-- => +-- let rec x = 42; y = "hi" in (x,y) +consLetRec + :: Ord v + => Bool -- isTop parameter + -> a -- annotation for overall let rec + -> (a, v, Term' vt v a) -- the binding + -> Term' vt v a -- the body + -> Term' vt v a +consLetRec isTop a (ab, vb, b) body = case body of + LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body + _ -> letRec isTop a [((ab,vb),b)] body + +letRec + :: Ord v + => Bool + -> a + -> [((a, v), Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec _ _ [] e = e +letRec isTop a bindings e = ABT.cycle' + a + (foldr (uncurry ABT.abs' . fst) z bindings) + where z = ABT.tm' a (LetRec isTop (map snd bindings) e) + + +-- | Smart constructor for let rec blocks. Each binding in the block may +-- reference any other binding in the block in its body (including itself), +-- and the output expression may also reference any binding in the block. +letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v +letRec_ _ [] e = e +letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) + where + z = ABT.tm (LetRec isTop (map snd bindings) e) + +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. +-- todo: delete me +let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v +let1_ isTop bindings e = foldr f e bindings + where + f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) + +-- | annotations are applied to each nested Let expression +let1 + :: Ord v + => IsTop + -> [((a, v), Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1 isTop bindings e = foldr f e bindings + where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) + +let1' + :: (Semigroup a, Ord v) + => IsTop + -> [(v, Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1' isTop bindings e = foldr f e bindings + where + ann = ABT.annotation + f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) + where a = ann b <> ann body + +-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v +-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e + +unLet1 + :: Var v + => Term' vt v a + -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) +unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) +unLet1 _ = Nothing + +-- | Satisfies `unLet (let' bs e) == Just (bs, e)` +unLet + :: Term2 vt at ap v a + -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) +unLet t = fixup (go t) + where + go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of + (env, t) -> ((isTop, v, b) : env, t) + go t = ([], t) + fixup ([], _) = Nothing + fixup bst = Just bst + +-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` +unLetRecNamed + :: Term2 vt at ap v a + -> Maybe + ( IsTop + , [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) + | length vs == length bs = Just (isTop, zip vs bs, e) +unLetRecNamed _ = Nothing + +unLetRec + :: (Monad m, Var v) + => Term2 vt at ap v a + -> Maybe + ( IsTop + , (v -> m v) + -> m + ( [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) + ) +unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just + ( isTop + , \freshen -> do + vs <- sequence [ freshen v | (v, _) <- bs ] + let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) + pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) + ) +unLetRec _ = Nothing + +unApps + :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unApps t = unAppsPred (t, const True) + +-- Same as unApps but taking a predicate controlling whether we match on a given function argument. +unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) + where + go (App' i o) acc | pred o = go i (o:acc) + go _ [] = [] + go fn args = fn:args + +unBinaryApp :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a) +unBinaryApp t = case unApps t of + Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) + _ -> Nothing + +-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" +unBinaryApps + :: Term2 vt at ap v a + -> Maybe + ( [(Term2 vt at ap v a, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unBinaryApps t = unBinaryAppsPred (t, const True) + +-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. +unBinaryAppsPred :: (Term2 vt at ap v a + ,Term2 vt at ap v a -> Bool) + -> Maybe ([(Term2 vt at ap v a, + Term2 vt at ap v a)], + Term2 vt at ap v a) +unBinaryAppsPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + _ -> Nothing + +unLams' + :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLams' t = unLamsPred' (t, const True) + +-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a +-- lambda extraction. +unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLamsOpt' t = case unLams' t of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams', but stops at any variable named `()`, which indicates a +-- delay (`'`) annotation which we want to preserve. +unLamsUntilDelay' + :: Var v + => Term2 vt at ap v a + -> Maybe ([v], Term2 vt at ap v a) +unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams' but taking a predicate controlling whether we match on a given binary function. +unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> + Maybe ([v], Term2 vt at ap v a) +unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of + Nothing -> Just ([v], body) + Just (vs, body) -> Just (v:vs, body) +unLamsPred' _ = Nothing + +unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) +unReqOrCtor (Constructor' r cid) = Just (r, cid) +unReqOrCtor (Request' r cid) = Just (r, cid) +unReqOrCtor _ = Nothing + +-- Dependencies including referenced data and effect decls +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) + +termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +termDependencies = + Set.fromList + . mapMaybe + ( LD.fold + (\_typeRef -> Nothing) + ( Referent.fold + (\termRef -> Just termRef) + (\_typeConRef _i _ct -> Nothing) + ) + ) + . toList + . labeledDependencies + +-- gets types from annotations and constructors +typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +typeDependencies = + Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + +-- Gets the types to which this term contains references via patterns and +-- data constructors. +constructorDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +constructorDependencies = + Set.unions + . generalizedDependencies (const mempty) + (const mempty) + Set.singleton + (const . Set.singleton) + Set.singleton + (const . Set.singleton) + Set.singleton + +generalizedDependencies + :: (Ord v, Ord vt, Ord r) + => (Reference -> r) + -> (Reference -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Term2 vt at ap v a + -> Set r +generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . Writer.execWriter . ABT.visit' f where + f t@(Ref r) = Writer.tell [termRef r] $> t + f t@(TermLink r) = case r of + Referent.Ref r -> Writer.tell [termRef r] $> t + Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t + Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t + f t@(TypeLink r) = Writer.tell [typeRef r] $> t + f t@(Ann _ typ) = + Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t + f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t + f t@(Int _) = Writer.tell [literalType Type.intRef] $> t + f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t + f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t + f t@(Text _) = Writer.tell [literalType Type.textRef] $> t + f t@(List _) = Writer.tell [literalType Type.listRef] $> t + f t@(Constructor r cid) = + Writer.tell [dataType r, dataConstructor r cid] $> t + f t@(Request r cid) = + Writer.tell [effectType r, effectConstructor r cid] $> t + f t@(Match _ cases) = traverse_ goPat cases $> t + f t = pure t + goPat (MatchCase pat _ _) = + Writer.tell . toList $ Pattern.generalizedDependencies literalType + dataConstructor + dataType + effectConstructor + effectType + pat + +labeledDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.termRef + LD.typeRef + LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef + +updateDependencies + :: Ord v + => Map Reference Reference + -> Map Reference Reference + -> Term v a + -> Term v a +updateDependencies termUpdates typeUpdates = ABT.rebuildUp go + where + -- todo: this function might need tweaking if we ever allow type replacements + -- would need to look inside pattern matching and constructor calls + go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) + go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) + go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) + go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp + go f = f + +-- | If the outermost term is a function application, +-- perform substitution of the argument into the body +betaReduce :: Var v => Term0 v -> Term0 v +betaReduce (App' (Lam' f) arg) = ABT.bind f arg +betaReduce e = e + +betaNormalForm :: Var v => Term0 v -> Term0 v +betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) +betaNormalForm e = e + +-- x -> f x => f +etaNormalForm :: Ord v => Term0 v -> Term0 v +etaNormalForm tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + where + step (LamNamed' v (App' f (Var' v'))) | v == v' = f + step tm = tm + _ -> tm + +-- x -> f x => f as long as `x` is a variable of type `Var.Eta` +etaReduceEtaVars :: Var v => Term0 v -> Term0 v +etaReduceEtaVars tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + where + ok v v' = v == v' && Var.typeOf v == Var.Eta + step (LamNamed' v (App' f (Var' v'))) | ok v v' = f + step tm = tm + _ -> tm + +-- This converts `Reference`s it finds that are in the input `Map` +-- back to free variables +unhashComponent :: forall v a. Var v + => Map Reference (Term v a) + -> Map Reference (v, Term v a) +unhashComponent m = let + usedVars = foldMap (Set.fromList . ABT.allVars) m + m' :: Map Reference (v, Term v a) + m' = evalState (Map.traverseWithKey assignVar m) usedVars where + assignVar r t = (,t) <$> ABT.freshenS (refNamed r) + unhash1 = ABT.rebuildUp' go where + go e@(Ref' r) = case Map.lookup r m' of + Nothing -> e + Just (v, _) -> var (ABT.annotation e) v + go e = e + in second unhash1 <$> m' + where + -- Variable whose name is derived from the given reference. + refNamed :: Var v => Reference -> v + refNamed ref = Var.named ("ℍ" <> Reference.toText ref) + +hashComponents + :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +hashClosedTerm :: Var v => Term v a -> Reference.Id +hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 + +-- The hash for a constructor +hashConstructor' + :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +hashConstructor' f r cid = + let +-- this is a bit circuitous, but defining everything in terms of hashComponents +-- ensure the hashing is always done in the same way + m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) + in case toList m of + [(r, _)] -> Reference.DerivedId r + _ -> error "unpossible" + +hashConstructor :: Reference -> ConstructorId -> Reference +hashConstructor = hashConstructor' $ constructor () + +hashRequest :: Reference -> ConstructorId -> Reference +hashRequest = hashConstructor' $ request () + +fromReferent :: Ord v + => a + -> Referent + -> Term2 vt at ap v a +fromReferent a = \case + Referent.Ref r -> ref a r + Referent.Con r i ct -> case ct of + CT.Data -> constructor a r i + CT.Effect -> request a r i + +instance Var v => Hashable1 (F v a p) where + hash1 hashCycle hash e + = let (tag, hashed, varint) = + (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) + in + case e of + -- So long as `Reference.Derived` ctors are created using the same + -- hashing function as is used here, this case ensures that references + -- are 'transparent' wrt hash and hashing is unaffected by whether + -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash + -- the same. + Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) + Ref (Reference.Derived h i n) -> Hashable.accumulate + [ tag 1 + , hashed $ Hashable.fromBytes (Hash.toBytes h) + , Hashable.Nat i + , Hashable.Nat n + ] + -- Note: start each layer with leading `1` byte, to avoid collisions + -- with types, which start each layer with leading `0`. + -- See `Hashable1 Type.F` + _ -> + Hashable.accumulate + $ tag 1 + : case e of + Nat i -> [tag 64, accumulateToken i] + Int i -> [tag 65, accumulateToken i] + Float n -> [tag 66, Hashable.Double n] + Boolean b -> [tag 67, accumulateToken b] + Text t -> [tag 68, accumulateToken t] + Char c -> [tag 69, accumulateToken c] + Blank b -> tag 1 : case b of + B.Blank -> [tag 0] + B.Recorded (B.Placeholder _ s) -> + [tag 1, Hashable.Text (Text.pack s)] + B.Recorded (B.Resolve _ s) -> + [tag 2, Hashable.Text (Text.pack s)] + Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] + Ref Reference.Derived {} -> + error "handled above, but GHC can't figure this out" + App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] + Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] + List as -> tag 5 : varint (Sequence.length as) : map + (hashed . hash) + (toList as) + Lam a -> [tag 6, hashed (hash a)] + -- note: we use `hashCycle` to ensure result is independent of + -- let binding order + LetRec _ as a -> case hashCycle as of + (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs + -- here, order is significant, so don't use hashCycle + Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + If b t f -> + [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] + Request r n -> [tag 10, accumulateToken r, varint n] + Constructor r n -> [tag 12, accumulateToken r, varint n] + Match e branches -> + tag 13 : hashed (hash e) : concatMap h branches + where + h (MatchCase pat guard branch) = concat + [ [accumulateToken pat] + , toList (hashed . hash <$> guard) + , [hashed (hash branch)] + ] + Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] + And x y -> [tag 16, hashed $ hash x, hashed $ hash y] + Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] + TermLink r -> [tag 18, accumulateToken r] + TypeLink r -> [tag 19, accumulateToken r] + +-- mostly boring serialization code below ... + +instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec + +instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where + Int x == Int y = x == y + Nat x == Nat y = x == y + Float x == Float y = x == y + Boolean x == Boolean y = x == y + Text x == Text y = x == y + Char x == Char y = x == y + Blank b == Blank q = b == q + Ref x == Ref y = x == y + TermLink x == TermLink y = x == y + TypeLink x == TypeLink y = x == y + Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 + Request r cid == Request r2 cid2 = r == r2 && cid == cid2 + Handle h b == Handle h2 b2 = h == h2 && b == b2 + App f a == App f2 a2 = f == f2 && a == a2 + Ann e t == Ann e2 t2 = e == e2 && t == t2 + List v == List v2 = v == v2 + If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 + And a b == And a2 b2 = a == a2 && b == b2 + Or a b == Or a2 b2 = a == a2 && b == b2 + Lam a == Lam b = a == b + LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 + Let _ binding body == Let _ binding2 body2 = + binding == binding2 && body == body2 + Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 + _ == _ = False + + +instance (Show v, Show a) => Show (F v a0 p a) where + showsPrec = go + where + go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n + go _ (Nat n ) = shows n + go _ (Float n ) = shows n + go _ (Boolean True ) = s "true" + go _ (Boolean False) = s "false" + go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k + go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x + go _ (Lam body ) = showParen True (s "λ " <> shows body) + go _ (List vs ) = showListWith shows (toList vs) + go _ (Blank b ) = case b of + B.Blank -> s "_" + B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) + B.Recorded (B.Resolve _ r) -> s r + go _ (Ref r) = s "Ref(" <> shows r <> s ")" + go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" + go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" + go _ (Let _ b body) = + showParen True (s "let " <> shows b <> s " in " <> shows body) + go _ (LetRec _ bs body) = showParen + True + (s "let rec" <> shows bs <> s " in " <> shows body) + go _ (Handle b body) = showParen + True + (s "handle " <> shows b <> s " in " <> shows body) + go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n + go _ (Match scrutinee cases) = showParen + True + (s "case " <> shows scrutinee <> s " of " <> shows cases) + go _ (Text s ) = shows s + go _ (Char c ) = shows c + go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n + go p (If c t f) = + showParen (p > 0) + $ s "if " + <> shows c + <> s " then " + <> shows t + <> s " else " + <> shows f + go p (And x y) = + showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y + go p (Or x y) = + showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y + (<>) = (.) + s = showString diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs new file mode 100644 index 0000000000..8c96b37f04 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs @@ -0,0 +1,42 @@ +module Unison.Codebase.FileCodebase.TermEdit where + +import Unison.Hashable (Hashable) +import qualified Unison.Hashable as H +import Unison.Codebase.FileCodebase.Reference (Reference) + +data TermEdit = Replace Reference Typing | Deprecate + deriving (Eq, Ord, Show) + +references :: TermEdit -> [Reference] +references (Replace r _) = [r] +references Deprecate = [] + +-- Replacements with the Same type can be automatically propagated. +-- Replacements with a Subtype can be automatically propagated but may result in dependents getting more general types, so requires re-inference. +-- Replacements of a Different type need to be manually propagated by the programmer. +data Typing = Same | Subtype | Different + deriving (Eq, Ord, Show) + +instance Hashable Typing where + tokens Same = [H.Tag 0] + tokens Subtype = [H.Tag 1] + tokens Different = [H.Tag 2] + +instance Hashable TermEdit where + tokens (Replace r t) = [H.Tag 0] ++ H.tokens r ++ H.tokens t + tokens Deprecate = [H.Tag 1] + +toReference :: TermEdit -> Maybe Reference +toReference (Replace r _) = Just r +toReference Deprecate = Nothing + +isTypePreserving :: TermEdit -> Bool +isTypePreserving e = case e of + Replace _ Same -> True + Replace _ Subtype -> True + _ -> False + +isSame :: TermEdit -> Bool +isSame e = case e of + Replace _ Same -> True + _ -> False diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs new file mode 100644 index 0000000000..816d910f9f --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.FileCodebase.Type where + +import Unison.Prelude + +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Codebase.FileCodebase.Reference (Reference) +import qualified Unison.Codebase.FileCodebase.Reference as Reference +import qualified Unison.Codebase.FileCodebase.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +-- | Base functor for types in the Unison language +data F a + = Ref Reference + | Arrow a a + | Ann a K.Kind + | App a a + | Effect a a + | Effects [a] + | Forall a + | IntroOuter a -- binder like ∀, used to introduce variables that are + -- bound by outer type signatures, to support scoped type + -- variables + deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) + +instance Eq1 F where (==#) = (==) +instance Ord1 F where compare1 = compare +instance Show1 F where showsPrec1 = showsPrec + +-- | Types are represented as ABTs over the base functor F, with variables in `v` +type Type v a = ABT.Term F v a + +wrapV :: Ord v => Type v a -> Type (ABT.V v) a +wrapV = ABT.vmap ABT.Bound + +freeVars :: Type v a -> Set v +freeVars = ABT.freeVars + +bindExternal + :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a +bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] + +bindNames + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq + +instance (Show v) => Show (Monotype v a) where + show = show . getPolytype + +-- Smart constructor which checks if a `Type` has no `Forall` quantifiers. +monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) +monotype t = Monotype <$> ABT.visit isMono t where + isMono (Forall' _) = Just Nothing + isMono _ = Nothing + +arity :: Type v a -> Int +arity (ForallNamed' _ body) = arity body +arity (Arrow' _ o) = 1 + arity o +arity (Ann' a _) = arity a +arity _ = 0 + +-- some smart patterns +pattern Ref' r <- ABT.Tm' (Ref r) +pattern Arrow' i o <- ABT.Tm' (Arrow i o) +pattern Arrow'' i es o <- Arrow' i (Effect'' es o) +pattern Arrows' spine <- (unArrows -> Just spine) +pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) +pattern Ann' t k <- ABT.Tm' (Ann t k) +pattern App' f x <- ABT.Tm' (App f x) +pattern Apps' f args <- (unApps -> Just (f, args)) +pattern Pure' t <- (unPure -> Just t) +pattern Effects' es <- ABT.Tm' (Effects es) +-- Effect1' must match at least one effect +pattern Effect1' e t <- ABT.Tm' (Effect e t) +pattern Effect' es t <- (unEffects1 -> Just (es, t)) +pattern Effect'' es t <- (unEffect0 -> (es, t)) +-- Effect0' may match zero effects +pattern Effect0' es t <- (unEffect0 -> (es, t)) +pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) +pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) +pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) +pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) +pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst + +unPure :: Ord v => Type v a -> Maybe (Type v a) +unPure (Effect'' [] t) = Just t +unPure (Effect'' _ _) = Nothing +unPure t = Just t + +unArrows :: Type v a -> Maybe [Type v a] +unArrows t = + case go t of [_] -> Nothing; l -> Just l + where go (Arrow' i o) = i : go o + go o = [o] + +unEffectfulArrows + :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) +unEffectfulArrows t = case t of + Arrow' i o -> Just (i, go o) + _ -> Nothing + where + go (Effect1' (Effects' es) (Arrow' i o)) = + (Just $ es >>= flattenEffects, i) : go o + go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] + go (Arrow' i o) = (Nothing, i) : go o + go t = [(Nothing, t)] + +unApps :: Type v a -> Maybe (Type v a, [Type v a]) +unApps t = case go t [] of + [] -> Nothing + [ _ ] -> Nothing + f : args -> Just (f, args) + where + go (App' i o) acc = go i (o : acc) + go fn args = fn : args + +unIntroOuters :: Type v a -> Maybe ([v], Type v a) +unIntroOuters t = go t [] + where go (IntroOuterNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just (reverse vs, body) + +-- Most code doesn't care about `introOuter` binders and is fine dealing with the +-- these outer variable references as free variables. This function strips out +-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. +stripIntroOuters :: Type v a -> Type v a +stripIntroOuters t = case unIntroOuters t of + Just (_, t) -> t + Nothing -> t + +unForalls :: Type v a -> Maybe ([v], Type v a) +unForalls t = go t [] + where go (ForallNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just(reverse vs, body) + +unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) +unEffect0 (Effect1' e a) = (flattenEffects e, a) +unEffect0 t = ([], t) + +unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) +unEffects1 (Effect1' (Effects' es) a) = Just (es, a) +unEffects1 _ = Nothing + +-- | True if the given type is a function, possibly quantified +isArrow :: ABT.Var v => Type v a -> Bool +isArrow (ForallNamed' _ t) = isArrow t +isArrow (Arrow' _ _) = True +isArrow _ = False + +-- some smart constructors + +ref :: Ord v => a -> Reference -> Type v a +ref a = ABT.tm' a . Ref + +refId :: Ord v => a -> Reference.Id -> Type v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Type v a +termLink a = ABT.tm' a . Ref $ termLinkRef + +typeLink :: Ord v => a -> Type v a +typeLink a = ABT.tm' a . Ref $ typeLinkRef + +derivedBase32Hex :: Ord v => Reference -> a -> Type v a +derivedBase32Hex r a = ref a r + +intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference +intRef = Reference.Builtin "Int" +natRef = Reference.Builtin "Nat" +floatRef = Reference.Builtin "Float" +booleanRef = Reference.Builtin "Boolean" +textRef = Reference.Builtin "Text" +charRef = Reference.Builtin "Char" +listRef = Reference.Builtin "Sequence" +bytesRef = Reference.Builtin "Bytes" +effectRef = Reference.Builtin "Effect" +termLinkRef = Reference.Builtin "Link.Term" +typeLinkRef = Reference.Builtin "Link.Type" + +builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference +builtinIORef = Reference.Builtin "IO" +fileHandleRef = Reference.Builtin "Handle" +filePathRef = Reference.Builtin "FilePath" +threadIdRef = Reference.Builtin "ThreadId" +socketRef = Reference.Builtin "Socket" + +mvarRef, tvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +tvarRef = Reference.Builtin "TVar" + +tlsRef :: Reference +tlsRef = Reference.Builtin "Tls" + +stmRef :: Reference +stmRef = Reference.Builtin "STM" + +tlsClientConfigRef :: Reference +tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" + +tlsServerConfigRef :: Reference +tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" + +tlsSignedCertRef :: Reference +tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" + +tlsPrivateKeyRef :: Reference +tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" + +tlsCipherRef :: Reference +tlsCipherRef = Reference.Builtin "Tls.Cipher" + +tlsVersionRef :: Reference +tlsVersionRef = Reference.Builtin "Tls.Version" + +hashAlgorithmRef :: Reference +hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" + +codeRef, valueRef :: Reference +codeRef = Reference.Builtin "Code" +valueRef = Reference.Builtin "Value" + +anyRef :: Reference +anyRef = Reference.Builtin "Any" + +any :: Ord v => a -> Type v a +any a = ref a anyRef + +builtin :: Ord v => a -> Text -> Type v a +builtin a = ref a . Reference.Builtin + +int :: Ord v => a -> Type v a +int a = ref a intRef + +nat :: Ord v => a -> Type v a +nat a = ref a natRef + +float :: Ord v => a -> Type v a +float a = ref a floatRef + +boolean :: Ord v => a -> Type v a +boolean a = ref a booleanRef + +text :: Ord v => a -> Type v a +text a = ref a textRef + +char :: Ord v => a -> Type v a +char a = ref a charRef + +fileHandle :: Ord v => a -> Type v a +fileHandle a = ref a fileHandleRef + +threadId :: Ord v => a -> Type v a +threadId a = ref a threadIdRef + +builtinIO :: Ord v => a -> Type v a +builtinIO a = ref a builtinIORef + +socket :: Ord v => a -> Type v a +socket a = ref a socketRef + +list :: Ord v => a -> Type v a +list a = ref a listRef + +bytes :: Ord v => a -> Type v a +bytes a = ref a bytesRef + +effectType :: Ord v => a -> Type v a +effectType a = ref a $ effectRef + +code, value :: Ord v => a -> Type v a +code a = ref a codeRef +value a = ref a valueRef + +app :: Ord v => a -> Type v a -> Type v a -> Type v a +app a f arg = ABT.tm' a (App f arg) + +-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one +-- meant for `app (f x) y` +apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a +apps = foldl' go where go f (a, t) = app a f t + +app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a +app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg + +apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a +apps' = foldl app' + +arrow :: Ord v => a -> Type v a -> Type v a -> Type v a +arrow a i o = ABT.tm' a (Arrow i o) + +arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a +arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o + +ann :: Ord v => a -> Type v a -> K.Kind -> Type v a +ann a e t = ABT.tm' a (Ann e t) + +forall :: Ord v => a -> v -> Type v a -> Type v a +forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) + +introOuter :: Ord v => a -> v -> Type v a -> Type v a +introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) + +iff :: Var v => Type v () +iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a + where aa = Var.named "a" + a = var () aa + f x = ((), x) + +iff' :: Var v => a -> Type v a +iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +iff2 :: Var v => a -> Type v a +iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +andor :: Ord v => Type v () +andor = arrows (f <$> [boolean(), boolean()]) $ boolean() + where f x = ((), x) + +andor' :: Ord v => a -> Type v a +andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a + where f x = (a, x) + +var :: Ord v => a -> v -> Type v a +var = ABT.annotatedVar + +v' :: Var v => Text -> Type v () +v' s = ABT.var (Var.named s) + +-- Like `v'`, but creates an annotated variable given an annotation +av' :: Var v => a -> Text -> Type v a +av' a s = ABT.annotatedVar a (Var.named s) + +forall' :: Var v => a -> [Text] -> Type v a -> Type v a +forall' a vs body = foldr (forall a) body (Var.named <$> vs) + +foralls :: Ord v => a -> [v] -> Type v a -> Type v a +foralls a vs body = foldr (forall a) body vs + +-- Note: `a -> b -> c` parses as `a -> (b -> c)` +-- the annotation associated with `b` will be the annotation for the `b -> c` +-- node +arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a +arrows ts result = foldr go result ts where + go = uncurry arrow + +-- The types of effectful computations +effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a +effect a es (Effect1' fs t) = + let es' = (es >>= flattenEffects) ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) + +effects :: Ord v => a -> [Type v a] -> Type v a +effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) + +effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a +effect1 a es (Effect1' fs t) = + let es' = flattenEffects es ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect1 a es t = ABT.tm' a (Effect es t) + +flattenEffects :: Type v a -> [Type v a] +flattenEffects (Effects' es) = es >>= flattenEffects +flattenEffects es = [es] + +-- The types of first-class effect values +-- which get deconstructed in effect handlers. +effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a +effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] + +-- Strips effects from a type. E.g. `{e} a` becomes `a`. +stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) +stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) +stripEffect t = ([], t) + +-- The type of the flipped function application operator: +-- `(a -> (a -> b) -> b)` +flipApply :: Var v => Type v () -> Type v () +flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) + where b = ABT.fresh t (Var.named "b") + +generalize' :: Var v => Var.Type -> Type v a -> Type v a +generalize' k t = generalize vsk t where + vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] + +-- | Bind the given variables with an outer `forall`, if they are used in `t`. +generalize :: Ord v => [v] -> Type v a -> Type v a +generalize vs t = foldr f t vs + where + f v t = + if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + +unforall :: Type v a -> Type v a +unforall (ForallsNamed' _ t) = t +unforall t = t + +unforall' :: Type v a -> ([v], Type v a) +unforall' (ForallsNamed' vs t) = (vs, t) +unforall' t = ([], t) + +dependencies :: Ord v => Type v a -> Set Reference +dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t + where f t@(Ref r) = Writer.tell [r] $> t + f t = pure t + +updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a +updateDependencies typeUpdates = ABT.rebuildUp go + where + go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) + go f = f + +usesEffects :: Ord v => Type v a -> Bool +usesEffects t = getAny . getConst $ ABT.visit go t where + go (Effect1' _ _) = Just (Const (Any True)) + go _ = Nothing + +-- Returns free effect variables in the given type, for instance, in: +-- +-- ∀ e3 . a ->{e,e2} b ->{e3} c +-- +-- This function would return the set {e, e2}, but not `e3` since `e3` +-- is bound by the enclosing forall. +freeEffectVars :: Ord v => Type v a -> Set v +freeEffectVars t = + Set.fromList . join . runIdentity $ + ABT.foreachSubterm go (snd <$> ABT.annotateBound t) + where + go t@(Effects' es) = + let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go t@(Effect1' e _) = + let frees = Set.fromList [ v | Var' v <- flattenEffects e ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go _ = pure [] + +-- Converts all unadorned arrows in a type to have fresh +-- existential ability requirements. For example: +-- +-- (a -> b) -> [a] -> [b] +-- +-- Becomes +-- +-- (a ->{e1} b) ->{e2} [a] ->{e3} [b] +existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) +existentializeArrows newVar t = ABT.visit go t + where + go t@(Arrow' a b) = case b of + -- If an arrow already has attached abilities, + -- leave it alone. Ex: `a ->{e} b` is kept as is. + Effect1' _ _ -> Just $ do + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + pure $ arrow (ABT.annotation t) a b + -- For unadorned arrows, make up a fresh variable. + -- So `a -> b` becomes `a ->{e} b`, using the + -- `newVar` variable generator. + _ -> Just $ do + e <- newVar + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + let ann = ABT.annotation t + pure $ arrow ann a (effect ann [var ann e] b) + go _ = Nothing + +purifyArrows :: (Ord v) => Type v a -> Type v a +purifyArrows = ABT.visitPure go + where + go t@(Arrow' a b) = case b of + Effect1' _ _ -> Nothing + _ -> Just $ arrow ann a (effect ann [] b) + where ann = ABT.annotation t + go _ = Nothing + +-- Remove free effect variables from the type that are in the set +removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a +removeEffectVars removals t = + let z = effects () [] + t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t + -- leave explicitly empty `{}` alone + removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) + removeEmpty t@(Effect1' e v) = + case flattenEffects e of + [] -> Just (ABT.visitPure removeEmpty v) + es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) + removeEmpty t@(Effects' es) = + Just $ effects (ABT.annotation t) (es >>= flattenEffects) + removeEmpty _ = Nothing + in ABT.visitPure removeEmpty t' + +-- Remove all effect variables from the type. +-- Used for type-based search, we apply this transformation to both the +-- indexed type and the query type, so the user can supply `a -> b` that will +-- match `a ->{e} b` (but not `a ->{IO} b`). +removeAllEffectVars :: ABT.Var v => Type v a -> Type v a +removeAllEffectVars t = let + allEffectVars = foldMap go (ABT.subterms t) + go (Effects' vs) = Set.fromList [ v | Var' v <- vs] + go (Effect1' (Var' v) _) = Set.singleton v + go _ = mempty + (vs, tu) = unforall' t + in generalize vs (removeEffectVars allEffectVars tu) + +removePureEffects :: ABT.Var v => Type v a -> Type v a +removePureEffects t | not Settings.removePureEffects = t + | otherwise = + generalize vs $ removeEffectVars (Set.filter isPure fvs) tu + where + (vs, tu) = unforall' t + fvs = freeEffectVars tu `Set.difference` ABT.freeVars t + -- If an effect variable is mentioned only once, it is on + -- an arrow `a ->{e} b`. Generalizing this to + -- `∀ e . a ->{e} b` gives us the pure arrow `a -> b`. + isPure v = ABT.occurrences v tu <= 1 + +editFunctionResult + :: forall v a + . Ord v + => (Type v a -> Type v a) + -> Type v a + -> Type v a +editFunctionResult f = go + where + go :: Type v a -> Type v a + go (ABT.Term s a t) = case t of + ABT.Tm (Forall t) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t + ABT.Tm (Arrow i o) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o + ABT.Abs v r -> + (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r + _ -> f (ABT.Term s a t) + +functionResult :: Type v a -> Maybe (Type v a) +functionResult = go False + where + go inArr (ForallNamed' _ body) = go inArr body + go _inArr (Arrow' _i o ) = go True o + go inArr t = if inArr then Just t else Nothing + + +-- | Bind all free variables (not in `except`) that start with a lowercase +-- letter and are unqualified with an outer `forall`. +-- `a -> a` becomes `∀ a . a -> a` +-- `B -> B` becomes `B -> B` (not changed) +-- `.foo -> .foo` becomes `.foo -> .foo` (not changed) +-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) +generalizeLowercase :: Var v => Set v -> Type v a -> Type v a +generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars + where + vars = + [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] + +-- Convert all free variables in `allowed` to variables bound by an `introOuter`. +freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a +freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars + where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed + +-- | This function removes all variable shadowing from the types and reduces +-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing +-- two different types. +cleanupVars :: Var v => [Type v a] -> [Type v a] +cleanupVars ts | not Settings.cleanupTypes = ts +cleanupVars ts = let + changedVars = cleanupVarsMap ts + in cleanupVars1' changedVars <$> ts + +-- Compute a variable replacement map from a collection of types, which +-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids +-- for multiple related types, like when reporting a type error. +cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v +cleanupVarsMap ts = let + varsByName = foldl' step Map.empty (ts >>= ABT.allVars) + step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m + changedVars = Map.fromList [ (v, Var.freshenId i v) + | (_, vs) <- Map.toList varsByName + , (v,i) <- nubOrd vs `zip` [0..]] + in changedVars + +cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a +cleanupVars1' = ABT.changeVars + +-- | This function removes all variable shadowing from the type and reduces +-- fresh ids to the minimum possible to avoid ambiguity. +cleanupVars1 :: Var v => Type v a -> Type v a +cleanupVars1 t | not Settings.cleanupTypes = t +cleanupVars1 t = let [t'] = cleanupVars [t] in t' + +-- This removes duplicates and normalizes the order of ability lists +cleanupAbilityLists :: Var v => Type v a -> Type v a +cleanupAbilityLists = ABT.visitPure go + where + -- leave explicitly empty `{}` alone + go (Effect1' (Effects' []) _v) = Nothing + go t@(Effect1' e v) = + let es = Set.toList . Set.fromList $ flattenEffects e + in case es of + [] -> Just (ABT.visitPure go v) + _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) + go _ = Nothing + +cleanups :: Var v => [Type v a] -> [Type v a] +cleanups ts = cleanupVars $ map cleanupAbilityLists ts + +cleanup :: Var v => Type v a -> Type v a +cleanup t | not Settings.cleanupTypes = t +cleanup t = cleanupVars1 . cleanupAbilityLists $ t + +toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference (Ref' r) = r +-- a bit of normalization - any unused type parameters aren't part of the hash +toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +toReference t = Reference.Derived (ABT.hash t) 0 1 + +toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions ty = + let (vs, _) = unforall' ty + gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty + in Set.fromList $ toReference . gen <$> ABT.subterms ty + +hashComponents + :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +instance Hashable1 F where + hash1 hashCycle hash e = + let + (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `0` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 0 : case e of + Ref r -> [tag 0, Hashable.accumulateToken r] + Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] + App a b -> [tag 2, hashed (hash a), hashed (hash b) ] + Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] + -- Example: + -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as + -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from + -- c) {Remote, Abort} (() -> {Abort} ()) + Effects es -> let + (hs, _) = hashCycle es + in tag 4 : map hashed hs + Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] + Forall a -> [tag 6, hashed (hash a)] + IntroOuter a -> [tag 7, hashed (hash a)] + +instance Show a => Show (F a) where + showsPrec = go where + go _ (Ref r) = shows r + go p (Arrow i o) = + showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o + go p (Ann t k) = + showParen (p > 1) $ shows t <> s":" <> shows k + go p (App f x) = + showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x + go p (Effects es) = showParen (p > 0) $ + s"{" <> shows es <> s"}" + go p (Effect e t) = showParen (p > 0) $ + showParen True $ shows e <> s" " <> showsPrec p t + go p (Forall body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"∀ " <> shows body + go p (IntroOuter body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"outer " <> shows body + (<>) = (.) + s = showString + diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs new file mode 100644 index 0000000000..7fe1e49115 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs @@ -0,0 +1,20 @@ +module Unison.Codebase.FileCodebase.TypeEdit where + +import Unison.Codebase.FileCodebase.Reference (Reference) +import Unison.Hashable (Hashable) +import qualified Unison.Hashable as H + +data TypeEdit = Replace Reference | Deprecate + deriving (Eq, Ord, Show) + +references :: TypeEdit -> [Reference] +references (Replace r) = [r] +references Deprecate = [] + +instance Hashable TypeEdit where + tokens (Replace r) = H.Tag 0 : H.tokens r + tokens Deprecate = [H.Tag 1] + +toReference :: TypeEdit -> Maybe Reference +toReference (Replace r) = Just r +toReference Deprecate = Nothing diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index dee76d036d..ceed3666c6 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -3,26 +3,25 @@ module Unison.Codebase.GitError where import Unison.Prelude import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo) -import U.Codebase.Sqlite.DbId (SchemaVersion) +import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo, ReadRemoteNamespace) type CodebasePath = FilePath -data GitError = NoGit - | UnrecognizableCacheDir Text CodebasePath - | UnrecognizableCheckoutDir Text CodebasePath - | CloneException ReadRepo String - | PushException WriteRepo String - | PushNoOp WriteRepo - -- url commit Diff of what would change on merge with remote - | PushDestinationHasNewStuff WriteRepo - | NoRemoteNamespaceWithHash ReadRepo ShortBranchHash - | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set Branch.Hash) - | CouldntLoadRootBranch ReadRepo Branch.Hash - | CouldntParseRootBranch ReadRepo String - | CouldntOpenCodebase ReadRepo CodebasePath - | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion - | SomeOtherError String - | CouldntLoadSyncedBranch Branch.Hash - deriving Show +data GitProtocolError + = NoGit + | UnrecognizableCacheDir ReadRepo CodebasePath + | UnrecognizableCheckoutDir ReadRepo CodebasePath + | CloneException ReadRepo String + | PushException WriteRepo String + | PushNoOp WriteRepo + -- url commit Diff of what would change on merge with remote + | PushDestinationHasNewStuff WriteRepo + | CleanupError SomeException + deriving Show + +data GitCodebaseError h + = NoRemoteNamespaceWithHash ReadRepo ShortBranchHash + | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set h) + | CouldntLoadRootBranch ReadRepo h + | CouldntLoadSyncedBranch ReadRemoteNamespace h + deriving Show diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 85a85e4e90..25e4d16053 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -1,45 +1,40 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Init where +module Unison.Codebase.Init + ( Init (..), + DebugName, + Pretty, + createCodebase, + initCodebaseAndExit, + openNewUcmCodebaseOrExit, + ) +where +import Unison.Codebase.Init.Type import System.Exit (exitFailure) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import UnliftIO.Directory (canonicalizePath) - -type Pretty = P.Pretty P.ColorText - -data CreateCodebaseError - = CreateCodebaseAlreadyExists - | CreateCodebaseOther Pretty +import qualified Unison.Codebase.Init.CreateCodebaseError as E +import Unison.Codebase.Init.CreateCodebaseError (Pretty) type DebugName = String -data Init m v a = Init - { -- | open an existing codebase - openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), - -- | create a new codebase - createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), - -- | given a codebase root, and given that the codebase root may have other junk in it, - -- give the path to the "actual" files; e.g. what a forked transcript should clone. - codebasePath :: CodebasePath -> CodebasePath - } - createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)) createCodebase debugName cbInit path = do prettyDir <- P.string <$> canonicalizePath path createCodebase' debugName cbInit path <&> mapLeft \case - CreateCodebaseAlreadyExists -> + E.CreateCodebaseAlreadyExists -> P.wrap $ "It looks like there's already a codebase in: " <> prettyDir - CreateCodebaseOther message -> + E.CreateCodebaseOther message -> P.wrap ("I ran into an error when creating the codebase in: " <> prettyDir) <> P.newline <> P.newline diff --git a/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs b/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs new file mode 100644 index 0000000000..ce575001be --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Init/CreateCodebaseError.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError(..), Pretty) where + +import qualified Unison.Util.Pretty as P + +type Pretty = P.Pretty P.ColorText + +data CreateCodebaseError + = CreateCodebaseAlreadyExists + | CreateCodebaseOther Pretty diff --git a/parser-typechecker/src/Unison/Codebase/Init/Type.hs b/parser-typechecker/src/Unison/Codebase/Init/Type.hs new file mode 100644 index 0000000000..62d8c9d014 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Init/Type.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Unison.Codebase.Init.Type (Init(..)) where + +import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError, Pretty) +import Unison.Codebase (Codebase, CodebasePath) + +type DebugName = String + +data Init m v a = Init + { -- | open an existing codebase + openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + -- | create a new codebase + createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + -- | given a codebase root, and given that the codebase root may have other junk in it, + -- give the path to the "actual" files; e.g. what a forked transcript should clone. + codebasePath :: CodebasePath -> CodebasePath + } + diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 3bd514b97c..154fbafeac 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -8,7 +8,7 @@ module Unison.Codebase.MainTerm where import Unison.Prelude -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Parser as Parser import qualified Unison.Term as Term import Unison.Term ( Term ) @@ -22,6 +22,7 @@ import Unison.Reference ( Reference ) import qualified Unison.Type as Type import Unison.Type ( Type ) import qualified Unison.Typechecker as Typechecker +import qualified Unison.Parser.Ann as Parser.Ann data MainTerm v = NotAFunctionName String @@ -41,7 +42,7 @@ getMainTerm loadTypeOfTerm parseNames0 mainName mainType = Nothing -> pure (NotAFunctionName mainName) Just hq -> do let refs = Names3.lookupHQTerm hq (Names3.Names parseNames0 mempty) - let a = Parser.External + let a = Parser.Ann.External case toList refs of [Referent.Ref ref] -> do typ <- loadTypeOfTerm ref diff --git a/parser-typechecker/src/Unison/Codebase/NameEdit.hs b/parser-typechecker/src/Unison/Codebase/NameEdit.hs deleted file mode 100644 index 3a872e1b0a..0000000000 --- a/parser-typechecker/src/Unison/Codebase/NameEdit.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Unison.Codebase.NameEdit where - -import Unison.Prelude - -import Unison.Reference (Reference) -import Unison.Hashable (Hashable, tokens) - -data NameEdit = - NameEdit { added :: Set Reference, removed :: Set Reference } - -instance Semigroup NameEdit where - NameEdit add1 del1 <> NameEdit add2 del2 = NameEdit (add1 <> add2) (del1 <> del2) - -instance Hashable NameEdit where - tokens (NameEdit added removed) = tokens (toList added, toList removed) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index d285fbf1d5..2514d6a929 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -4,13 +4,69 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Path where - +module Unison.Codebase.Path + ( Path (..), + Path' (..), + Absolute (..), + Relative (..), + Resolve (..), + pattern Empty, + singleton, + Unison.Codebase.Path.uncons, + empty, + absoluteEmpty, + relativeEmpty', + currentPath, + prefix, + unprefix, + prefixName, + unprefixName, + HQSplit, + Split, + Split', + HQSplit', + ancestors, + + -- * tests + isCurrentPath, + isRoot, + isRoot', + + -- * things that could be replaced with `Convert` instances + absoluteToPath', + fromAbsoluteSplit, + fromList, + fromName, + fromName', + fromPath', + fromText, + toAbsoluteSplit, + toList, + toName, + toName', + toText, + unsplit, + unsplit', + unsplitHQ, + unsplitHQ', + + -- * things that could be replaced with `Parse` instances + splitFromName, + hqSplitFromName', + + -- * things that could be replaced with `Cons` instances + cons, + + -- * things that could be replaced with `Snoc` instances + snoc, + unsnoc, + ) +where import Unison.Prelude hiding (empty, toList) import Data.Bifunctor ( first ) import Data.List.Extra ( stripPrefix, dropPrefix ) -import Control.Lens hiding (unsnoc, cons, snoc) +import Control.Lens hiding (Empty, unsnoc, cons, snoc) import qualified Control.Lens as Lens import qualified Data.Foldable as Foldable import qualified Data.Text as Text @@ -83,7 +139,7 @@ type HQSplit' = (Path', HQ'.HQSegment) type SplitAbsolute = (Absolute, NameSegment) type HQSplitAbsolute = (Absolute, HQ'.HQSegment) --- examples: +-- | examples: -- unprefix .foo.bar .blah == .blah (absolute paths left alone) -- unprefix .foo.bar id == id (relative paths starting w/ nonmatching prefix left alone) -- unprefix .foo.bar foo.bar.baz == baz (relative paths w/ common prefix get stripped) @@ -282,6 +338,7 @@ hqSplitFromName' = fmap (fmap HQ'.fromName) . Lens.unsnoc . fromName' splitFromName :: Name -> Maybe Split splitFromName = unsnoc . fromName +-- | what is this? —AI unprefixName :: Absolute -> Name -> Name unprefixName prefix = toName . unprefix prefix . fromName' diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs new file mode 100644 index 0000000000..a88a9207f7 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Path.Parse + ( parsePath', + parsePathImpl', + parseSplit', + definitionNameSegment, + parseHQSplit, + parseHQSplit', + parseShortHashOrHQSplit', + wordyNameSegment, + ) +where + +import Unison.Prelude hiding (empty, toList) + +import Unison.Codebase.Path + +import Data.Bifunctor ( first ) +import Data.List.Extra ( stripPrefix, dropPrefix ) +import Control.Lens hiding (unsnoc, cons, snoc) +import qualified Control.Lens as Lens +import qualified Data.Foldable as Foldable +import qualified Data.Text as Text +import Data.Sequence (Seq((:<|),(:|>) )) +import qualified Data.Sequence as Seq +import Unison.Name ( Name, Convert, Parse ) +import qualified Unison.Name as Name +import Unison.Util.Monoid (intercalateMap) +import qualified Unison.Lexer as Lexer +import qualified Unison.HashQualified' as HQ' +import qualified Unison.ShortHash as SH + +import Unison.NameSegment ( NameSegment(NameSegment)) +import qualified Unison.NameSegment as NameSegment + +-- .libs.blah.poo is Absolute +-- libs.blah.poo is Relative +-- Left is some parse error tbd +parsePath' :: String -> Either String Path' +parsePath' p = case parsePathImpl' p of + Left e -> Left e + Right (p, "" ) -> Right p + Right (p, rem) -> case parseSegment rem of + Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg)) + Right (_, rem) -> + Left ("extra characters after " <> show p <> ": " <> show rem) + Left e -> Left e + +-- implementation detail of parsePath' and parseSplit' +-- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") +-- foo.bar.baz becomes `Right (foo.bar, "baz") +-- baz becomes `Right (, "baz") +-- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths. +-- TODO: Get rid of this thing. +parsePathImpl' :: String -> Either String (Path', String) +parsePathImpl' p = case p of + "." -> Right (Path' . Left $ absoluteEmpty, "") + '.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p + p -> over _1 (Path' . Right . Relative . fromList) <$> segs p + where + go f p = case f p of + Right (a, "") -> case Lens.unsnoc (Name.segments' $ Text.pack a) of + Nothing -> Left "empty path" + Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last) + Right (segs, '.' : rem) -> + let segs' = Name.segments' (Text.pack segs) + in Right (NameSegment <$> segs', rem) + Right (segs, rem) -> + Left $ "extra characters after " <> segs <> ": " <> show rem + Left e -> Left e + segs p = go parseSegment p + +parseSegment :: String -> Either String (String, String) +parseSegment s = + first show + . (Lexer.wordyId <> Lexer.symbolyId) + <> unit' + <> const (Left ("I expected an identifier but found " <> s)) + $ s + +wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment +wordyNameSegment s = case Lexer.wordyId0 s of + Left e -> Left (show e) + Right (a, "") -> Right (NameSegment (Text.pack a)) + Right (a, rem) -> + Left $ "trailing characters after " <> show a <> ": " <> show rem + +optionalWordyNameSegment :: String -> Either String NameSegment +optionalWordyNameSegment "" = Right $ NameSegment "" +optionalWordyNameSegment s = wordyNameSegment s + +-- Parse a name segment like "()" +unit' :: String -> Either String (String, String) +unit' s = case stripPrefix "()" s of + Nothing -> Left $ "Expected () but found: " <> s + Just rem -> Right ("()", rem) + +unit :: String -> Either String NameSegment +unit s = case unit' s of + Right (_, "" ) -> Right $ NameSegment "()" + Right (_, rem) -> Left $ "trailing characters after (): " <> show rem + Left _ -> Left $ "I don't know how to parse " <> s + + +definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s + where + symbolyNameSegment s = case Lexer.symbolyId0 s of + Left e -> Left (show e) + Right (a, "") -> Right (NameSegment (Text.pack a)) + Right (a, rem) -> + Left $ "trailing characters after " <> show a <> ": " <> show rem + +-- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz) +-- parseSplit' wordyNameSegment "foo.bar.+" returns Left err +-- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +) +parseSplit' :: (String -> Either String NameSegment) + -> String + -> Either String Split' +parseSplit' lastSegment p = do + (p', rem) <- parsePathImpl' p + seg <- lastSegment rem + pure (p', seg) + +parseShortHashOrHQSplit' :: String -> Either String (Either SH.ShortHash HQSplit') +parseShortHashOrHQSplit' s = + case Text.breakOn "#" $ Text.pack s of + ("","") -> error $ "encountered empty string parsing '" <> s <> "'" + (n,"") -> do + (p, rem) <- parsePathImpl' (Text.unpack n) + seg <- definitionNameSegment rem + pure $ Right (p, HQ'.NameOnly seg) + ("", sh) -> do + sh <- maybeToRight (shError s) . SH.fromText $ sh + pure $ Left sh + (n, sh) -> do + (p, rem) <- parsePathImpl' (Text.unpack n) + seg <- definitionNameSegment rem + hq <- maybeToRight (shError s) . + fmap (\sh -> (p, HQ'.HashQualified seg sh)) . + SH.fromText $ sh + pure $ Right hq + where + shError s = "couldn't parse shorthash from " <> s + +parseHQSplit :: String -> Either String HQSplit +parseHQSplit s = case parseHQSplit' s of + Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg) + Right (Path' Left{}, _) -> + Left $ "Sorry, you can't use an absolute name like " <> s <> " here." + Left e -> Left e + +parseHQSplit' :: String -> Either String HQSplit' +parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of + ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" + ("", _ ) -> Left "Sorry, you can't use a hash-only reference here." + (n , "") -> do + (p, rem) <- parsePath n + seg <- definitionNameSegment rem + pure (p, HQ'.NameOnly seg) + (n, sh) -> do + (p, rem) <- parsePath n + seg <- definitionNameSegment rem + maybeToRight (shError s) + . fmap (\sh -> (p, HQ'.HashQualified seg sh)) + . SH.fromText + $ sh + where + shError s = "couldn't parse shorthash from " <> s + parsePath n = do + x <- parsePathImpl' $ Text.unpack n + pure $ case x of + (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") + x -> x + +toAbsoluteSplit :: Absolute -> (Path', a) -> (Absolute, a) +toAbsoluteSplit a (p, s) = (resolve a p, s) + +fromSplit' :: (Path', a) -> (Path, a) +fromSplit' (Path' (Left (Absolute p)), a) = (p, a) +fromSplit' (Path' (Right (Relative p)), a) = (p, a) + +fromAbsoluteSplit :: (Absolute, a) -> (Path, a) +fromAbsoluteSplit (Absolute p, a) = (p, a) + +-- splitFromName :: Name -> Maybe Split +-- splitFromName = unsnoc . fromName + +unprefixName :: Absolute -> Name -> Name +unprefixName prefix = toName . unprefix prefix . fromName' + +prefixName :: Absolute -> Name -> Name +prefixName p = toName . prefix p . fromName' + +singleton :: NameSegment -> Path +singleton n = fromList [n] + +cons :: NameSegment -> Path -> Path +cons = Lens.cons + +snoc :: Path -> NameSegment -> Path +snoc = Lens.snoc + +snoc' :: Path' -> NameSegment -> Path' +snoc' = Lens.snoc + +unsnoc :: Path -> Maybe (Path, NameSegment) +unsnoc = Lens.unsnoc + +uncons :: Path -> Maybe (NameSegment, Path) +uncons = Lens.uncons + +--asDirectory :: Path -> Text +--asDirectory p = case toList p of +-- NameSegment "_root_" : (Seq.fromList -> tail) -> +-- "/" <> asDirectory (Path tail) +-- other -> Text.intercalate "/" . fmap NameSegment.toText $ other + +-- -- > Path.fromName . Name.unsafeFromText $ ".Foo.bar" +-- -- /Foo/bar +-- -- Int./ -> "Int"/"/" +-- -- pkg/Int.. -> "pkg"/"Int"/"." +-- -- Int./foo -> error because "/foo" is not a valid NameSegment +-- -- and "Int." is not a valid NameSegment +-- -- and "Int" / "" / "foo" is not a valid path (internal "") +-- -- todo: fromName needs to be a little more complicated if we want to allow +-- -- identifiers called Function.(.) +-- fromName :: Name -> Path +-- fromName = fromList . Name.segments + +-- fromName' :: Name -> Path' +-- fromName' n = case take 1 (Name.toString n) of +-- "." -> Path' . Left . Absolute $ Path seq +-- _ -> Path' . Right $ Relative path +-- where +-- path = fromName n +-- seq = toSeq path + +-- toName :: Path -> Name +-- toName = Name.unsafeFromText . toText + +-- | Convert a Path' to a Name +toName' :: Path' -> Name +toName' = Name.unsafeFromText . toText' + +fromText :: Text -> Path +fromText = \case + "" -> empty + t -> fromList $ NameSegment <$> Name.segments' t + +toText' :: Path' -> Text +toText' = \case + Path' (Left (Absolute path)) -> Text.cons '.' (toText path) + Path' (Right (Relative path)) -> toText path diff --git a/parser-typechecker/src/Unison/Codebase/Reflog.hs b/parser-typechecker/src/Unison/Codebase/Reflog.hs index 07df0bd380..58b8f6bf40 100644 --- a/parser-typechecker/src/Unison/Codebase/Reflog.hs +++ b/parser-typechecker/src/Unison/Codebase/Reflog.hs @@ -1,30 +1,29 @@ {-# LANGUAGE ViewPatterns #-} -module Unison.Codebase.Reflog where +module Unison.Codebase.Reflog (Entry(..), fromText, toText) where +import Data.Coerce (Coercible, coerce) import Data.Text (Text) import qualified Data.Text as Text -import Unison.Codebase.Branch (Hash) -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Hash as Hash -data Entry = - Entry - { from :: Hash - , to :: Hash - , reason :: Text - } +data Entry h = Entry + { from :: h, + to :: h, + reason :: Text + } -fromText :: Text -> Maybe Entry +fromText :: Coercible h Hash.Hash => Text -> Maybe (Entry h) fromText t = case Text.words t of (Hash.fromBase32Hex -> Just old) : (Hash.fromBase32Hex -> Just new) : (Text.unwords -> reason) -> - Just $ Entry (Causal.RawHash old) (Causal.RawHash new) reason + Just $ Entry (coerce old) (coerce new) reason _ -> Nothing - -toText :: Entry -> Text +toText :: Coercible h Hash.Hash => Entry h -> Text toText (Entry old new reason) = - Text.unwords [ Hash.base32Hex . Causal.unRawHash $ old - , Hash.base32Hex . Causal.unRawHash $ new - , reason ] + Text.unwords + [ Hash.base32Hex . coerce $ old, + Hash.base32Hex . coerce $ new, + reason + ] diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 653b8a7a24..73f2885978 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -10,9 +10,9 @@ import Data.Bifunctor (first) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Unison.Codebase.CodeLookup as CL -import qualified Unison.Codebase as Codebase +import qualified Unison.Codebase.CodeLookup.Util as CL import Unison.UnisonFile ( UnisonFile ) -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Term as Term import Unison.Type ( Type ) import Unison.Var ( Var ) @@ -20,9 +20,12 @@ import qualified Unison.Var as Var import Unison.Reference ( Reference ) import qualified Unison.Reference as Reference import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Type as UF import Unison.Builtin.Decls (pattern TupleTerm', tupleTerm) import qualified Unison.Util.Pretty as P import qualified Unison.PrettyPrintEnv as PPE +import Unison.WatchKind (WatchKind) +import qualified Unison.WatchKind as WK type Error = P.Pretty P.ColorText type Term v = Term.Term v () @@ -36,7 +39,6 @@ data Runtime v = Runtime -> IO (Either Error (Term v)) , mainType :: Type v Ann , ioTestType :: Type v Ann - , needsContainment :: Bool } type IsCacheHit = Bool @@ -48,7 +50,7 @@ type WatchResults v a = (Either Error -- Bindings: ( [(v, Term v)] -- Map watchName (loc, hash, expression, value, isHit) - , Map v (a, UF.WatchKind, Reference, Term v, Term v, IsCacheHit) + , Map v (a, WatchKind, Reference, Term v, Term v, IsCacheHit) )) -- Evaluates the watch expressions in the file, returning a `Map` of their @@ -74,7 +76,7 @@ evaluateWatches code ppe evaluationCache rt uf = do m = first Reference.DerivedId <$> Term.hashComponents (Map.fromList (UF.terms uf <> UF.allWatches uf)) watches = Set.fromList (fst <$> UF.allWatches uf) - watchKinds :: Map v UF.WatchKind + watchKinds :: Map v WatchKind watchKinds = Map.fromList [ (v, k) | (k, ws) <- Map.toList (UF.watches uf) , (v,_) <- ws ] unann = Term.amap (const ()) @@ -134,12 +136,8 @@ evaluateTerm' codeLookup cache ppe rt tm = do Just r -> pure (Right r) Nothing -> do let uf = UF.UnisonFileId mempty mempty mempty - (Map.singleton UF.RegularWatch [(Var.nameds "result", tm)]) - runnable <- - if needsContainment rt - then Codebase.makeSelfContained' codeLookup uf - else pure uf - r <- evaluateWatches codeLookup ppe cache rt runnable + (Map.singleton WK.RegularWatch [(Var.nameds "result", tm)]) + r <- evaluateWatches codeLookup ppe cache rt uf pure $ r <&> \(_,map) -> let [(_loc, _kind, _hash, _src, value, _isHit)] = Map.elems map in value diff --git a/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs b/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs deleted file mode 100644 index 57d2f645c0..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Serialization/PutT.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Unison.Codebase.Serialization.PutT where - -import Data.Bytes.Put -import qualified Data.Serialize.Put as Ser -import Data.Serialize.Put ( PutM - , runPutM - ) - -newtype PutT m a = PutT { unPutT :: m (PutM a) } - -instance Monad m => MonadPut (PutT m) where - putWord8 = PutT . pure . putWord8 - {-# INLINE putWord8 #-} - putByteString = PutT . pure . putByteString - {-# INLINE putByteString #-} - putLazyByteString = PutT . pure . putLazyByteString - {-# INLINE putLazyByteString #-} - flush = PutT $ pure flush - {-# INLINE flush #-} - putWord16le = PutT . pure . putWord16le - {-# INLINE putWord16le #-} - putWord16be = PutT . pure . putWord16be - {-# INLINE putWord16be #-} - putWord16host = PutT . pure . putWord16host - {-# INLINE putWord16host #-} - putWord32le = PutT . pure . putWord32le - {-# INLINE putWord32le #-} - putWord32be = PutT . pure . putWord32be - {-# INLINE putWord32be #-} - putWord32host = PutT . pure . putWord32host - {-# INLINE putWord32host #-} - putWord64le = PutT . pure . putWord64le - {-# INLINE putWord64le #-} - putWord64be = PutT . pure . putWord64be - {-# INLINE putWord64be #-} - putWord64host = PutT . pure . putWord64host - {-# INLINE putWord64host #-} - putWordhost = PutT . pure . putWordhost - {-# INLINE putWordhost #-} - -instance Functor m => Functor (PutT m) where - fmap f (PutT m) = PutT $ fmap (fmap f) m - -instance Applicative m => Applicative (PutT m) where - pure = PutT . pure . pure - (PutT f) <*> (PutT a) = PutT $ (<*>) <$> f <*> a - -instance Monad m => Monad (PutT m) where - (PutT m) >>= f = PutT $ do - putm <- m - let (a, bs) = runPutM putm - putm' <- unPutT $ f a - let (b, bs') = runPutM putm' - pure $ do - Ser.putByteString bs - Ser.putByteString bs' - pure b diff --git a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs index 8353ca6646..e71ef7adf5 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs @@ -4,11 +4,10 @@ module Unison.Codebase.ShortBranchHash where import Unison.Prelude -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Hash as Hash import qualified Data.Text as Text import qualified Data.Set as Set +import Data.Coerce (Coercible, coerce) newtype ShortBranchHash = ShortBranchHash { toText :: Text } -- base32hex characters @@ -17,15 +16,15 @@ newtype ShortBranchHash = toString :: ShortBranchHash -> String toString = Text.unpack . toText -toHash :: ShortBranchHash -> Maybe Branch.Hash -toHash = fmap Causal.RawHash . Hash.fromBase32Hex . toText +toHash :: Coercible Hash.Hash h => ShortBranchHash -> Maybe h +toHash = fmap coerce . Hash.fromBase32Hex . toText -fromHash :: Int -> Branch.Hash -> ShortBranchHash +fromHash :: Coercible h Hash.Hash => Int -> h -> ShortBranchHash fromHash len = - ShortBranchHash . Text.take len . Hash.base32Hex . Causal.unRawHash + ShortBranchHash . Text.take len . Hash.base32Hex . coerce -fullFromHash :: Branch.Hash -> ShortBranchHash -fullFromHash = ShortBranchHash . Hash.base32Hex . Causal.unRawHash +fullFromHash :: Coercible h Hash.Hash => h -> ShortBranchHash +fullFromHash = ShortBranchHash . Hash.base32Hex . coerce -- abc -> SBH abc -- #abc -> SBH abc diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 1c8eca35d7..8eeefe3d80 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -15,8 +15,9 @@ where import qualified Control.Concurrent import qualified Control.Exception +import Control.Exception.Safe (MonadCatch) import Control.Monad (filterM, unless, when, (>=>)) -import Control.Monad.Except (ExceptT(ExceptT), MonadError (throwError), runExceptT) +import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError), runExceptT, withExceptT) import qualified Control.Monad.Except as Except import Control.Monad.Extra (ifM, unlessM) import qualified Control.Monad.Extra as Monad @@ -26,10 +27,10 @@ import qualified Control.Monad.State as State import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import Data.Bifunctor (Bifunctor (bimap, first), second) -import qualified Data.Either.Combinators as Either import qualified Data.Char as Char +import qualified Data.Either.Combinators as Either import Data.Foldable (Foldable (toList), for_, traverse_) -import Data.Functor (void, (<&>), ($>)) +import Data.Functor (void, ($>), (<&>)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -47,12 +48,13 @@ import qualified System.Console.ANSI as ANSI import System.FilePath (()) import qualified System.FilePath as FilePath import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) -import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Reference as C.Reference import U.Codebase.Sqlite.Connection (Connection (Connection)) import qualified U.Codebase.Sqlite.Connection as Connection +import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import qualified U.Codebase.Sqlite.JournalMode as JournalMode import qualified U.Codebase.Sqlite.ObjectType as OT +import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 @@ -62,6 +64,7 @@ import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 import qualified U.Util.Monoid as Monoid import qualified U.Util.Set as Set +import U.Util.Timing (time) import qualified Unison.Builtin as Builtins import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase1 @@ -69,23 +72,25 @@ import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), writeToRead, printWriteRepo) -import Unison.Codebase.GitError (GitError) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), printWriteRepo, writeToRead) import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Init as Codebase import qualified Unison.Codebase.Init as Codebase1 +import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 import Unison.Codebase.Patch (Patch) import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv +import qualified Unison.Codebase.SqliteCodebase.GitError as GitError import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) +import qualified Unison.Codebase.Type as C import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as Decl import Unison.Hash (Hash) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude (MaybeT (runMaybeT), fromMaybe, isJust, trace, traceM) import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -98,14 +103,11 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type -import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P -import U.Util.Timing (time) +import qualified Unison.WatchKind as UF import UnliftIO (MonadIO, catchIO, finally, liftIO) import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.STM -import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) -import Control.Exception.Safe (MonadCatch) debug, debugProcessBranches, debugCommitFailedTransaction :: Bool debug = False @@ -626,7 +628,7 @@ sqliteCodebase debugName root = do clearWatches :: MonadIO m => m () clearWatches = runDB conn Ops.clearWatches - getReflog :: MonadIO m => m [Reflog.Entry] + getReflog :: MonadIO m => m [Reflog.Entry Branch.Hash] getReflog = liftIO $ ( do @@ -695,7 +697,7 @@ sqliteCodebase debugName root = do >>= traverse (Cv.referentid2to1 (getCycleLen "referentsByPrefix") getDeclType) declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) let declReferents = - [ Referent.Con' (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct) + [ Referent.ConId (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct) | (h, pos, len, ct, cids) <- declReferents', cid <- cids ] @@ -993,15 +995,15 @@ viewRemoteBranch' :: forall m. (MonadIO m, MonadCatch m) => ReadRemoteNamespace -> - m (Either GitError (m (), Branch m, CodebasePath)) -viewRemoteBranch' (repo, sbh, path) = runExceptT do + m (Either C.GitError (m (), Branch m, CodebasePath)) +viewRemoteBranch' (repo, sbh, path) = runExceptT @C.GitError do -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch repo - ifM + remotePath <- time "Git fetch" . withExceptT C.GitProtocolError $ pullBranch repo + ifM @(ExceptT C.GitError m) (codebaseExists remotePath) do lift (sqliteCodebase "viewRemoteBranch.gitCache" remotePath) >>= \case - Left sv -> ExceptT . pure . Left $ GitError.UnrecognizedSchemaVersion repo remotePath sv + Left sv -> ExceptT . pure . Left . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath sv Right (closeCodebase, codebase) -> do -- try to load the requested branch from it branch <- time "Git fetch (sbh)" $ case sbh of @@ -1011,20 +1013,20 @@ viewRemoteBranch' (repo, sbh, path) = runExceptT do -- this NoRootBranch case should probably be an error too. Left Codebase1.NoRootBranch -> pure Branch.empty Left (Codebase1.CouldntLoadRootBranch h) -> - throwError $ GitError.CouldntLoadRootBranch repo h + throwError . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h Left (Codebase1.CouldntParseRootBranch s) -> - throwError $ GitError.CouldntParseRootBranch repo s + throwError . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s Right b -> pure b -- load from a specific `ShortBranchHash` Just sbh -> do branchCompletions <- lift $ Codebase1.branchHashesByPrefix codebase sbh case toList branchCompletions of - [] -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh + [] -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh [h] -> lift (Codebase1.getBranchForHash codebase h) >>= \case Just b -> pure b - Nothing -> throwError $ GitError.NoRemoteNamespaceWithHash repo sbh - _ -> throwError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions + Nothing -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh + _ -> throwError . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions pure (closeCodebase, Branch.getAt' path branch, remotePath) -- else there's no initialized codebase at this repo; we pretend there's an empty one. -- I'm thinking we should probably return an error value instead. @@ -1037,8 +1039,8 @@ pushGitRootBranch :: Connection -> Branch m -> WriteRepo -> - m (Either GitError ()) -pushGitRootBranch srcConn branch repo = runExceptT @GitError do + m (Either C.GitError ()) +pushGitRootBranch srcConn branch repo = runExceptT @C.GitError do -- pull the remote repo to the staging directory -- open a connection to the staging codebase -- create a savepoint on the staging codebase @@ -1048,7 +1050,7 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do -- if it fails, rollback to the savepoint and clean up. -- set up the cache dir - remotePath <- time "Git fetch" $ pullBranch (writeToRead repo) + remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo) destConn <- openOrCreateCodebaseConnection "push.dest" remotePath flip runReaderT destConn $ Q.savepoint "push" @@ -1073,7 +1075,7 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do ++ "." Just False -> do Q.rollbackRelease "push" - throwError $ GitError.PushDestinationHasNewStuff repo + throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo Just True -> do setRepoRoot newRootHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 0f029232c1..531f19d9b0 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -48,8 +48,9 @@ import Unison.Hash (Hash) import qualified Unison.Hash as V1 import qualified Unison.Kind as V1.Kind import qualified Unison.NameSegment as V1 -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import qualified Unison.Parser as Ann +import qualified Unison.Parser.Ann as Ann import qualified Unison.Pattern as V1.Pattern import qualified Unison.Reference as V1 import qualified Unison.Reference as V1.Reference @@ -62,6 +63,7 @@ import qualified Unison.Util.Relation as Relation import qualified Unison.Util.Star3 as V1.Star3 import qualified Unison.Var as V1.Var import qualified Unison.Var as Var +import qualified Unison.WatchKind as V1.WK sbh1to2 :: V1.ShortBranchHash -> V2.ShortBranchHash sbh1to2 (V1.ShortBranchHash b32) = V2.ShortBranchHash b32 @@ -76,16 +78,16 @@ decltype1to2 = \case CT.Data -> V2.Decl.Data CT.Effect -> V2.Decl.Effect -watchKind1to2 :: V1.Var.WatchKind -> V2.WatchKind +watchKind1to2 :: V1.WK.WatchKind -> V2.WatchKind watchKind1to2 = \case - V1.Var.RegularWatch -> V2.WatchKind.RegularWatch - V1.Var.TestWatch -> V2.WatchKind.TestWatch + V1.WK.RegularWatch -> V2.WatchKind.RegularWatch + V1.WK.TestWatch -> V2.WatchKind.TestWatch other -> error $ "What kind of watchkind is " ++ other ++ "?" -watchKind2to1 :: V2.WatchKind -> V1.Var.WatchKind +watchKind2to1 :: V2.WatchKind -> V1.WK.WatchKind watchKind2to1 = \case - V2.WatchKind.RegularWatch -> V1.Var.RegularWatch - V2.WatchKind.TestWatch -> V1.Var.TestWatch + V2.WatchKind.RegularWatch -> V1.WK.RegularWatch + V2.WatchKind.TestWatch -> V1.WK.TestWatch term1to2 :: Hash -> V1.Term.Term V1.Symbol Ann -> V2.Term.Term V2.Symbol term1to2 h = @@ -342,9 +344,9 @@ referent1to2 = \case referentid2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id referentid2to1 lookupSize lookupCT = \case - V2.RefId r -> V1.Ref' <$> referenceid2to1 lookupSize r + V2.RefId r -> V1.RefId <$> referenceid2to1 lookupSize r V2.ConId r i -> - V1.Con' <$> referenceid2to1 lookupSize r + V1.ConId <$> referenceid2to1 lookupSize r <*> pure (fromIntegral i) <*> lookupCT (V2.ReferenceDerived r) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs new file mode 100644 index 0000000000..c9d51fc77e --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs @@ -0,0 +1,10 @@ +module Unison.Codebase.SqliteCodebase.GitError where + +import Unison.Codebase.Editor.RemoteRepo (ReadRepo) +import Unison.CodebasePath (CodebasePath) +import U.Codebase.Sqlite.DbId (SchemaVersion) + +data GitSqliteCodebaseError + = GitCouldntParseRootBranchHash ReadRepo String + | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion + deriving Show \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/TermEdit.hs index 7e2239024f..df753c84c5 100644 --- a/parser-typechecker/src/Unison/Codebase/TermEdit.hs +++ b/parser-typechecker/src/Unison/Codebase/TermEdit.hs @@ -3,9 +3,6 @@ module Unison.Codebase.TermEdit where import Unison.Hashable (Hashable) import qualified Unison.Hashable as H import Unison.Reference (Reference) -import qualified Unison.Typechecker as Typechecker -import Unison.Type (Type) -import Unison.Var (Var) data TermEdit = Replace Reference Typing | Deprecate deriving (Eq, Ord, Show) @@ -43,9 +40,3 @@ isSame :: TermEdit -> Bool isSame e = case e of Replace _ Same -> True _ -> False - -typing :: Var v => Type v loc -> Type v loc -> Typing -typing newType oldType | Typechecker.isEqual newType oldType = Same - | Typechecker.isSubtype newType oldType = Subtype - | otherwise = Different - diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs b/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs new file mode 100644 index 0000000000..1d9db07a04 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/TermEdit/Typing.hs @@ -0,0 +1,12 @@ +module Unison.Codebase.TermEdit.Typing where + +import Unison.Codebase.TermEdit (Typing (Different, Same, Subtype)) +import Unison.Type (Type) +import qualified Unison.Typechecker as Typechecker +import Unison.Var (Var) + +typing :: Var v => Type v loc -> Type v loc -> Typing +typing newType oldType + | Typechecker.isEqual newType oldType = Same + | Typechecker.isSubtype newType oldType = Subtype + | otherwise = Different diff --git a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs index dc0af1dd8d..32668286dc 100644 --- a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs +++ b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs @@ -25,7 +25,7 @@ import Unison.CommandLine import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal import Unison.Symbol (Symbol) @@ -41,6 +41,7 @@ import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Runtime import qualified Unison.CommandLine.InputPattern as IP import qualified Unison.Runtime.Interface as RTI diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs new file mode 100644 index 0000000000..406c503474 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Codebase.Type (Codebase (..), CodebasePath, GitError(..), GetRootBranchError (..), SyncToDir) where + +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo) +import Unison.Codebase.Patch (Patch) +import qualified Unison.Codebase.Reflog as Reflog +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.SyncMode (SyncMode) +import Unison.CodebasePath (CodebasePath) +import Unison.DataDeclaration (Decl) +import Unison.Prelude +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.ShortHash (ShortHash) +import Unison.Term (Term) +import Unison.Type (Type) +import qualified Unison.WatchKind as WK +import Unison.Codebase.GitError (GitProtocolError, GitCodebaseError) +import Unison.Codebase.FileCodebase.Codebase (GitFileCodebaseError) +import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError) + +type SyncToDir m = + CodebasePath -> -- dest codebase + SyncMode -> + Branch m -> -- branch to sync to dest codebase + m () + +-- | Abstract interface to a user's codebase. +-- +-- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. +data Codebase m v a = Codebase + { getTerm :: Reference.Id -> m (Maybe (Term v a)), + getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)), + getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), + putTerm :: Reference.Id -> Term v a -> Type v a -> m (), + putTypeDeclaration :: Reference.Id -> Decl v a -> m (), + getRootBranch :: m (Either GetRootBranchError (Branch m)), + putRootBranch :: Branch m -> m (), + rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), + getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)), + putBranch :: Branch m -> m (), + branchExists :: Branch.Hash -> m Bool, + getPatch :: Branch.EditHash -> m (Maybe Patch), + putPatch :: Branch.EditHash -> Patch -> m (), + patchExists :: Branch.EditHash -> m Bool, + dependentsImpl :: Reference -> m (Set Reference.Id), + -- This copies all the dependencies of `b` from the specified Codebase into this one + syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + -- This copies all the dependencies of `b` from this Codebase + syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), + viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)), + pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()), + -- Watch expressions are part of the codebase, the `Reference.Id` is + -- the hash of the source of the watch expression, and the `Term v a` + -- is the evaluated result of the expression, decompiled to a term. + watches :: WK.WatchKind -> m [Reference.Id], + getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)), + putWatch :: WK.WatchKind -> Reference.Id -> Term v a -> m (), + clearWatches :: m (), + getReflog :: m [Reflog.Entry Branch.Hash], + appendReflog :: Text -> Branch m -> Branch m -> m (), + -- list of terms of the given type + termsOfTypeImpl :: Reference -> m (Set Referent.Id), + -- list of terms that mention the given type anywhere in their signature + termsMentioningTypeImpl :: Reference -> m (Set Referent.Id), + -- number of base58 characters needed to distinguish any two references in the codebase + hashLength :: m Int, + termReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id), + termReferentsByPrefix :: ShortHash -> m (Set Referent.Id), + branchHashLength :: m Int, + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash), + -- returns `Nothing` to not implemented, fallback to in-memory + -- also `Nothing` if no LCA + -- The result is undefined if the two hashes are not in the codebase. + -- Use `Codebase.lca` which wraps this in a nice API. + lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)), + -- `beforeImpl` returns `Nothing` if not implemented by the codebase + -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase + -- + -- Use `Codebase.before` which wraps this in a nice API. + beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) + } + +data GetRootBranchError + = NoRootBranch + | CouldntParseRootBranch String + | CouldntLoadRootBranch Branch.Hash + deriving Show + +data GitError + = GitProtocolError GitProtocolError + | GitCodebaseError (GitCodebaseError Branch.Hash) + | GitFileCodebaseError GitFileCodebaseError + | GitSqliteCodebaseError GitSqliteCodebaseError + deriving Show \ No newline at end of file diff --git a/parser-typechecker/src/Unison/CodebasePath.hs b/parser-typechecker/src/Unison/CodebasePath.hs new file mode 100644 index 0000000000..f9424cf32c --- /dev/null +++ b/parser-typechecker/src/Unison/CodebasePath.hs @@ -0,0 +1,13 @@ +module Unison.CodebasePath + ( CodebasePath, + getCodebaseDir, + ) +where + +import Control.Monad.IO.Class (MonadIO) +import UnliftIO.Directory (getHomeDirectory) + +type CodebasePath = FilePath + +getCodebaseDir :: MonadIO m => Maybe CodebasePath -> m CodebasePath +getCodebaseDir = maybe getHomeDirectory pure diff --git a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs index 5d6ccf1f19..32ea85e3f0 100644 --- a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs +++ b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs @@ -19,6 +19,8 @@ import qualified Unison.DataDeclaration as DD import qualified Unison.DeclPrinter as DP import qualified Unison.NamePrinter as NP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Referent as Referent import qualified Unison.Reference as Reference import qualified Unison.ShortHash as SH diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index 14418648c9..4a88083179 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -27,8 +27,11 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Text.Megaparsec as P import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.CommandLine.InputPattern as I import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index d6956c8f09..887e679165 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -27,7 +27,7 @@ import Unison.PrettyTerminal import Unison.CommandLine.InputPattern (ArgumentType (suggestions), InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered, shortenDirectory) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Symbol (Symbol) import qualified Control.Concurrent.Async as Async import qualified Data.Map as Map diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 4f0e6c2e76..9c879a0ded 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -38,6 +38,7 @@ import System.Directory ( canonicalizePath ) import qualified Unison.ABT as ABT import qualified Unison.UnisonFile as UF +import Unison.Codebase.Type (GitError(GitSqliteCodebaseError, GitProtocolError, GitCodebaseError)) import Unison.Codebase.GitError import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Patch as Patch @@ -73,8 +74,10 @@ import Unison.NamePrinter (prettyHashQualified, import Unison.Names2 (Names'(..), Names0) import qualified Unison.Names2 as Names import qualified Unison.Names3 as Names -import Unison.Parser (Ann, startingLine) +import Unison.Parser.Ann (Ann, startingLine) import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Codebase.Runtime as Runtime import Unison.PrintError ( prettyParseError , printNoteWithSource @@ -112,6 +115,9 @@ import qualified Unison.ShortHash as SH import Unison.LabeledDependency as LD import Unison.Codebase.Editor.RemoteRepo (ReadRepo, WriteRepo) import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) +import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError(UnrecognizedSchemaVersion, GitCouldntParseRootBranchHash)) +import qualified Unison.Referent' as Referent +import qualified Unison.WatchKind as WK type Pretty = P.Pretty P.ColorText @@ -669,75 +675,78 @@ notifyUser dir o = case o of TodoOutput names todo -> pure (todoOutput names todo) GitError input e -> pure $ case e of - CouldntOpenCodebase repo localPath -> P.wrap $ "I couldn't open the repository at" - <> prettyReadRepo repo <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap - $ "I don't know how to interpret schema version " <> P.shown v - <> "in the repository at" <> prettyReadRepo repo - <> "in the cache directory at" <> P.backticked' (P.string localPath) "." - CouldntParseRootBranch repo s -> P.wrap $ "I couldn't parse the string" - <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadRepo repo <> ".") - CouldntLoadSyncedBranch h -> P.wrap $ "I just finished importing the branch" - <> P.red (P.shown h) <> "but now I can't find it." - NoGit -> P.wrap $ - "I couldn't find git. Make sure it's installed and on your path." - CloneException repo msg -> P.wrap $ - "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" - <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg - PushNoOp repo -> P.wrap $ - "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." - PushException repo msg -> P.wrap $ - "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" - <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg - UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" - <> P.backticked (P.text uri) <> "already exists at" - <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" - <> "be a git repository, so I'm not sure what to do next. Delete it?" - UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" - <> P.backticked (P.text uri) <> "into a cache directory at" - <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" - <> "result as a git repository, so I'm not sure what to do next." - PushDestinationHasNewStuff repo -> - P.callout "⏸" . P.lines $ [ - P.wrap $ "The repository at" <> prettyWriteRepo repo - <> "has some changes I don't know about.", - "", - P.wrap $ "If you want to " <> push <> "you can do:", "", - P.indentN 2 pull, "", - P.wrap $ - "to merge these changes locally," <> - "then try your" <> push <> "again." - ] - where - push = P.group . P.backticked . P.string . IP1.patternName $ IP.patternFromInput input - pull = P.group . P.backticked $ IP.inputStringFromInput input - CouldntLoadRootBranch repo hash -> P.wrap - $ "I couldn't load the designated root hash" - <> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")") - <> "from the repository at" <> prettyReadRepo repo - NoRemoteNamespaceWithHash repo sbh -> P.wrap - $ "The repository at" <> prettyReadRepo repo - <> "doesn't contain a namespace with the hash prefix" - <> (P.blue . P.text . SBH.toText) sbh - RemoteNamespaceHashAmbiguous repo sbh hashes -> P.lines [ - P.wrap $ "The namespace hash" <> prettySBH sbh - <> "at" <> prettyReadRepo repo - <> "is ambiguous." - <> "Did you mean one of these hashes?", - "", - P.indentN 2 $ P.lines - (prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2) - <$> Set.toList hashes), - "", - P.wrap "Try again with a few more hash characters to disambiguate." - ] - SomeOtherError msg -> P.callout "‼" . P.lines $ [ - P.wrap "I ran into an error:", "", - P.indentN 2 (P.string msg), "", - P.wrap $ "Check the logging messages above for more info." - ] + -- CouldntOpenCodebase repo localPath -> P.wrap $ "I couldn't open the repository at" + -- <> prettyReadRepo repo <> "in the cache directory at" + -- <> P.backticked' (P.string localPath) "." + GitSqliteCodebaseError e -> case e of + UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap + $ "I don't know how to interpret schema version " <> P.shown v + <> "in the repository at" <> prettyReadRepo repo + <> "in the cache directory at" <> P.backticked' (P.string localPath) "." + GitCouldntParseRootBranchHash repo s -> P.wrap $ "I couldn't parse the string" + <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" + <> P.group (prettyReadRepo repo <> ".") + -- CouldntLoadSyncedBranch h -> P.wrap $ "I just finished importing the branch" + -- <> P.red (P.shown h) <> "but now I can't find it." + GitProtocolError e -> case e of + NoGit -> P.wrap $ + "I couldn't find git. Make sure it's installed and on your path." + CloneException repo msg -> P.wrap $ + "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" + <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg + PushNoOp repo -> P.wrap $ + "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." + PushException repo msg -> P.wrap $ + "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" + <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg + UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" + <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) <> "already exists at" + <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" + <> "be a git repository, so I'm not sure what to do next. Delete it?" + UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" + <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) <> "into a cache directory at" + <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" + <> "result as a git repository, so I'm not sure what to do next." + PushDestinationHasNewStuff repo -> + P.callout "⏸" . P.lines $ [ + P.wrap $ "The repository at" <> prettyWriteRepo repo + <> "has some changes I don't know about.", + "", + P.wrap $ "If you want to " <> push <> "you can do:", "", + P.indentN 2 pull, "", + P.wrap $ + "to merge these changes locally," <> + "then try your" <> push <> "again." + ] + where + push = P.group . P.backticked . P.string . IP1.patternName $ IP.patternFromInput input + pull = P.group . P.backticked $ IP.inputStringFromInput input + GitCodebaseError e -> case e of + CouldntLoadRootBranch repo hash -> P.wrap + $ "I couldn't load the designated root hash" + <> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")") + <> "from the repository at" <> prettyReadRepo repo + NoRemoteNamespaceWithHash repo sbh -> P.wrap + $ "The repository at" <> prettyReadRepo repo + <> "doesn't contain a namespace with the hash prefix" + <> (P.blue . P.text . SBH.toText) sbh + RemoteNamespaceHashAmbiguous repo sbh hashes -> P.lines [ + P.wrap $ "The namespace hash" <> prettySBH sbh + <> "at" <> prettyReadRepo repo + <> "is ambiguous." + <> "Did you mean one of these hashes?", + "", + P.indentN 2 $ P.lines + (prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2) + <$> Set.toList hashes), + "", + P.wrap "Try again with a few more hash characters to disambiguate." + ] + -- SomeOtherError msg -> P.callout "‼" . P.lines $ [ + -- P.wrap "I ran into an error:", "", + -- P.indentN 2 (P.string msg), "", + -- P.wrap $ "Check the logging messages above for more info." + -- ] ListEdits patch ppe -> do let types = Patch._typeEdits patch @@ -1880,7 +1889,7 @@ watchPrinter => Text -> PPE.PrettyPrintEnv -> Ann - -> UF.WatchKind + -> WK.WatchKind -> Term v () -> Runtime.IsCacheHit -> Pretty @@ -1911,7 +1920,7 @@ watchPrinter src ppe ann kind term isHit = P.lines [ fromString (show lineNum) <> " | " <> P.text line , case (kind, term) of - (UF.TestWatch, Term.List' tests) -> foldMap renderTest tests + (WK.TestWatch, Term.List' tests) -> foldMap renderTest tests _ -> P.lines [ fromString (replicate lineNumWidth ' ') <> fromString extra diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index 3c956fc4c2..503d9269b8 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -23,7 +23,6 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import Unison.Reference ( Reference(DerivedId) ) import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText ( SyntaxText ) import qualified Unison.Term as Term import qualified Unison.Type as Type import qualified Unison.TypePrinter as TypePrinter @@ -32,6 +31,8 @@ import qualified Unison.Util.Pretty as P import Unison.Var ( Var ) import qualified Unison.Var as Var +type SyntaxText = S.SyntaxText' Reference + prettyDecl :: Var v => PrettyPrintEnv diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index baf09329a7..1e71c17a10 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -15,18 +15,23 @@ import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) import qualified Unison.DataDeclaration as DD import qualified Unison.Lexer as L import Unison.Parser +import Unison.Parser.Ann (Ann) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermParser as TermParser import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.TypeParser as TypeParser -import Unison.UnisonFile (UnisonFile(..), environmentFor) +import Unison.UnisonFile (UnisonFile(..)) import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Env as UF +import Unison.UnisonFile.Names (environmentFor) import qualified Unison.Util.List as List import Unison.Var (Var) import qualified Unison.Var as Var +import qualified Unison.WatchKind as UF import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name resolutionFailures :: Ord v => [Names.ResolutionFailure v Ann] -> P v x diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index 155d4d5dc9..3f41742b94 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -21,7 +21,7 @@ import qualified Unison.ABT as ABT import qualified Unison.Blank as Blank import qualified Unison.Name as Name import qualified Unison.Names3 as Names -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import qualified Unison.Parsers as Parsers import qualified Unison.Referent as Referent import Unison.Reference (Reference) @@ -33,6 +33,8 @@ import qualified Unison.Typechecker as Typechecker import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.Typechecker.Context as Context import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Names as UF +import qualified Unison.UnisonFile.Type as UF import qualified Unison.Util.List as List import qualified Unison.Util.Relation as Rel import Unison.Var (Var) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 12c2fde690..7d902f1052 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -36,14 +36,9 @@ import qualified Text.Megaparsec.Error as EP import qualified Text.Megaparsec.Char as CP import Text.Megaparsec.Char (char) import qualified Text.Megaparsec.Char.Lexer as LP +import Unison.Lexer.Pos (Pos (Pos), Column, Line, column, line) import qualified Unison.Util.Bytes as Bytes -type Line = Int -type Column = Int - -data Pos = Pos {-# Unpack #-} !Line {-# Unpack #-} !Column deriving (Eq,Ord) -instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col - type BlockName = String type Layout = [(BlockName,Column)] @@ -908,12 +903,6 @@ notLayout t = case payload t of Open _ -> False _ -> True -line :: Pos -> Line -line (Pos line _) = line - -column :: Pos -> Column -column (Pos _ column) = column - -- `True` if the tokens are adjacent, with no space separating the two touches :: Token a -> Token b -> Bool touches (end -> t) (start -> t2) = @@ -1178,12 +1167,3 @@ instance ShowToken (Token Lexeme) where instance Applicative Token where pure a = Token a (Pos 0 0) (Pos 0 0) Token f start _ <*> Token a _ end = Token (f a) start end - -instance Semigroup Pos where (<>) = mappend - -instance Monoid Pos where - mempty = Pos 0 0 - Pos line col `mappend` Pos line2 col2 = - if line2 == 0 then Pos line (col + col2) - else Pos (line + line2) col2 - diff --git a/parser-typechecker/src/Unison/Lexer/Pos.hs b/parser-typechecker/src/Unison/Lexer/Pos.hs new file mode 100644 index 0000000000..6e529d1d17 --- /dev/null +++ b/parser-typechecker/src/Unison/Lexer/Pos.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Lexer.Pos (Pos (..), Line, Column, line, column) where + +type Line = Int +type Column = Int + +data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column deriving (Eq, Ord) + +line :: Pos -> Line +line (Pos line _) = line + +column :: Pos -> Column +column (Pos _ column) = column + +instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col + +instance Semigroup Pos where (<>) = mappend + +instance Monoid Pos where + mempty = Pos 0 0 + Pos line col `mappend` Pos line2 col2 = + if line2 == 0 + then Pos line (col + col2) + else Pos (line + line2) col2 diff --git a/parser-typechecker/src/Unison/NamePrinter.hs b/parser-typechecker/src/Unison/NamePrinter.hs index 3d90878c8b..e14c41d3c5 100644 --- a/parser-typechecker/src/Unison/NamePrinter.hs +++ b/parser-typechecker/src/Unison/NamePrinter.hs @@ -12,11 +12,12 @@ import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH -import Unison.Util.SyntaxText (SyntaxText) import qualified Unison.Util.SyntaxText as S import Unison.Util.Pretty (Pretty) import qualified Unison.Util.Pretty as PP +type SyntaxText = S.SyntaxText' Reference + prettyName :: IsString s => Name -> Pretty s prettyName = PP.text . Name.toText diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 7d5ea2cc98..b3425765fa 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -29,15 +29,17 @@ import qualified Unison.Pattern as Pattern import Unison.Term (MatchCase (..)) import Unison.Var (Var) import qualified Unison.Var as Var -import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Error as UF import Unison.Util.Bytes (Bytes) import Unison.Name as Name import Unison.Names3 (Names) import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import Control.Monad.Reader.Class (asks) import qualified Unison.Hashable as Hashable import Unison.Referent (Referent) import Unison.Reference (Reference) +import Unison.Parser.Ann (Ann(..)) debug :: Bool debug = False @@ -107,28 +109,6 @@ data Error v | PatternArityMismatch Int Int Ann -- PatternArityMismatch expectedArity actualArity location deriving (Show, Eq, Ord) -data Ann - = Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos } - | External - | Ann { start :: L.Pos, end :: L.Pos } - deriving (Eq, Ord, Show) - -startingLine :: Ann -> Maybe L.Line -startingLine (Ann (L.line -> line) _) = Just line -startingLine _ = Nothing - -instance Monoid Ann where - mempty = External - mappend = (<>) - -instance Semigroup Ann where - Ann s1 _ <> Ann _ e2 = Ann s1 e2 - -- If we have a concrete location from a file, use it - External <> a = a - a <> External = a - Intrinsic <> a = a - a <> Intrinsic = a - tokenToPair :: L.Token a -> (Ann, a) tokenToPair t = (ann t, L.payload t) diff --git a/parser-typechecker/src/Unison/Parser/Ann.hs b/parser-typechecker/src/Unison/Parser/Ann.hs new file mode 100644 index 0000000000..5a0d089725 --- /dev/null +++ b/parser-typechecker/src/Unison/Parser/Ann.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Parser.Ann where + +import qualified Unison.Lexer.Pos as L + +data Ann + = Intrinsic -- { sig :: String, start :: L.Pos, end :: L.Pos } + | External + | Ann {start :: L.Pos, end :: L.Pos} + deriving (Eq, Ord, Show) + +startingLine :: Ann -> Maybe L.Line +startingLine (Ann (L.line -> line) _) = Just line +startingLine _ = Nothing + +instance Monoid Ann where + mempty = External + mappend = (<>) + +instance Semigroup Ann where + Ann s1 _ <> Ann _ e2 = Ann s1 e2 + -- If we have a concrete location from a file, use it + External <> a = a + a <> External = a + Intrinsic <> a = a + a <> Intrinsic = a diff --git a/parser-typechecker/src/Unison/Parsers.hs b/parser-typechecker/src/Unison/Parsers.hs index be787c3d1d..07d04024ba 100644 --- a/parser-typechecker/src/Unison/Parsers.hs +++ b/parser-typechecker/src/Unison/Parsers.hs @@ -8,7 +8,7 @@ import Prelude hiding ( readFile ) import qualified Unison.Names3 as Names import qualified Unison.Builtin as Builtin import qualified Unison.FileParser as FileParser -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import qualified Unison.Parser as Parser import Unison.PrintError ( prettyParseError , defaultWidth ) diff --git a/parser-typechecker/src/Unison/Path.hs b/parser-typechecker/src/Unison/Path.hs deleted file mode 100644 index 5ce88ed774..0000000000 --- a/parser-typechecker/src/Unison/Path.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | --- Provides a typeclass for a general concept of a path into --- a treelike structure. We have a root or empty path, paths --- may be concatenated, and a pair of paths may be factored into --- paths relative to their lowest common ancestor in the tree. - -module Unison.Path where - -import Unison.Prelude - --- | Satisfies: --- * `extend root p == p` and `extend p root == p` --- * `extend` is associative, `extend (extend p1 p2) p3 == extend p1 (extend p2 p3)` --- * `lca root p == root` and `lca p root == root` --- * `case factor p p2 of (r,p',p2') -> extend r p' == p && extend r p2' == p2` -class Path p where - -- | The root or empty path - root :: p - -- | Concatenate two paths - extend :: p -> p -> p - -- | Extract the lowest common ancestor and the path from the LCA to each argument - factor :: p -> p -> (p,(p,p)) - -- | Satisfies `factor (parent p) p == (parent p, (root, tl)` and - -- `extend (parent p) tl == p` - parent :: p -> p - --- | Compute the lowest common ancestor of two paths -lca :: Path p => p -> p -> p -lca p p2 = fst (factor p p2) - --- | `isSubpath p1 p2` is true if `p2 == extend p1 x` for some `x` -isSubpath :: (Eq p, Path p) => p -> p -> Bool -isSubpath p1 p2 = lca p1 p2 == p1 - -instance Eq a => Path (Maybe a) where - root = Nothing - extend = (<|>) - parent _ = Nothing - factor p1 p2 | p1 == p2 = (p1, (Nothing, Nothing)) - factor p1 p2 = (Nothing, (p1,p2)) - -instance Eq a => Path [a] where - root = [] - extend = (++) - parent p | null p = [] - parent p = init p - factor p1 p2 = (take shared p1, (drop shared p1, drop shared p2)) - where shared = length (takeWhile id $ zipWith (==) p1 p2) - -instance Path () where - root = () - parent _ = () - extend _ _ = () - factor u _ = (u,(u,u)) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index e01c10c48c..3855381c4f 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -1,24 +1,17 @@ {-# Language OverloadedStrings #-} -module Unison.PrettyPrintEnv where +module Unison.PrettyPrintEnv (PrettyPrintEnv(..), patterns, patternName, termName, typeName) where import Unison.Prelude import Unison.HashQualified ( HashQualified ) import Unison.Name ( Name ) -import Unison.Names3 ( Names ) import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) -import Unison.Util.List (safeHead) import qualified Data.Map as Map import qualified Unison.HashQualified as HQ -import qualified Unison.Name as Name -import qualified Unison.Names3 as Names -import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.ConstructorType as CT -import qualified Unison.HashQualified' as HQ' -import qualified Data.Set as Set data PrettyPrintEnv = PrettyPrintEnv { -- names for terms, constructors, and requests @@ -33,49 +26,6 @@ patterns ppe r cid = terms ppe (Referent.Con r cid CT.Data) instance Show PrettyPrintEnv where show _ = "PrettyPrintEnv" -fromNames :: Int -> Names -> PrettyPrintEnv -fromNames len names = PrettyPrintEnv terms' types' where - terms' r = shortestName . Set.map HQ'.toHQ $ Names.termName len r names - types' r = shortestName . Set.map HQ'.toHQ $ Names.typeName len r names - shortestName ns = safeHead $ HQ.sortByLength (toList ns) - -fromSuffixNames :: Int -> Names -> PrettyPrintEnv -fromSuffixNames len names = fromNames len (Names.suffixify names) - -fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl -fromNamesDecl len names = - PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) - --- A pair of PrettyPrintEnvs: --- - suffixifiedPPE uses the shortest unique suffix --- - unsuffixifiedPPE uses the shortest full name --- --- Generally, we want declarations LHS (the `x` in `x = 23`) to use the --- unsuffixified names, so the LHS is an accurate description of where in the --- namespace the definition lives. For everywhere else, we can use the --- suffixified version. -data PrettyPrintEnvDecl = PrettyPrintEnvDecl { - unsuffixifiedPPE :: PrettyPrintEnv, - suffixifiedPPE :: PrettyPrintEnv - } deriving Show - --- declarationPPE uses the full name for references that are --- part the same cycle as the input reference, used to ensures --- recursive definitions are printed properly, for instance: --- --- foo.bar x = foo.bar x --- and not --- foo.bar x = bar x -declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv -declarationPPE ppe rd = PrettyPrintEnv tm ty where - comp = Reference.members (Reference.componentFor rd) - tm r0@(Referent.Ref r) = if Set.member r comp - then terms (unsuffixifiedPPE ppe) r0 - else terms (suffixifiedPPE ppe) r0 - tm r = terms (suffixifiedPPE ppe) r - ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r - else types (suffixifiedPPE ppe) r - -- Left-biased union of environments unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv unionLeft e1 e2 = PrettyPrintEnv @@ -117,25 +67,3 @@ instance Monoid PrettyPrintEnv where mappend = unionLeft instance Semigroup PrettyPrintEnv where (<>) = mappend - --- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' --- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. - --- Note that a Suffix can include dots. -type Suffix = Text --- Each member of a Prefix list is dot-free. -type Prefix = [Text] --- Keys are FQNs, values are shorter names which are equivalent, thanks to use --- statements that are in scope. -type Imports = Map Name Suffix - --- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. -elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name -elideFQN imports hq = - let hash = HQ.toHash hq - name' = do name <- HQ.toName hq - let hit = fmap Name.unsafeFromText (Map.lookup name imports) - -- Cut out the "const id $" to get tracing of FQN elision attempts. - let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) - t (pure $ fromMaybe name hit) - in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs new file mode 100644 index 0000000000..18c9c20774 --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs @@ -0,0 +1,32 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Unison.HashQualified as HQ +import Unison.Name (Name) +import qualified Unison.Name as Name + +-- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' +-- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. + +-- Note that a Suffix can include dots. +type Suffix = Text +-- Each member of a Prefix list is dot-free. +type Prefix = [Text] +-- Keys are FQNs, values are shorter names which are equivalent, thanks to use +-- statements that are in scope. +type Imports = Map Name Suffix + +-- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. +elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name +elideFQN imports hq = + let hash = HQ.toHash hq + name' = do name <- HQ.toName hq + let hit = fmap Name.unsafeFromText (Map.lookup name imports) + -- Cut out the "const id $" to get tracing of FQN elision attempts. + let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) + t (pure $ fromMaybe name hit) + in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs new file mode 100644 index 0000000000..91c05d41be --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs @@ -0,0 +1,144 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) where + +import Unison.Prelude + +import Unison.HashQualified ( HashQualified ) +import Unison.Name ( Name ) +import Unison.Names3 ( Names ) +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) +import Unison.Util.List (safeHead) +import qualified Data.Map as Map +import qualified Unison.HashQualified as HQ +import qualified Unison.Name as Name +import qualified Unison.Names3 as Names +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import qualified Unison.ConstructorType as CT +import qualified Data.Set as Set +import Unison.PrettyPrintEnv (PrettyPrintEnv (PrettyPrintEnv)) +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl)) + +-- data PrettyPrintEnv = PrettyPrintEnv { +-- -- names for terms, constructors, and requests +-- terms :: Referent -> Maybe (HashQualified Name), +-- -- names for types +-- types :: Reference -> Maybe (HashQualified Name) } + +-- 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) + +-- instance Show PrettyPrintEnv where +-- show _ = "PrettyPrintEnv" + +fromNames :: Int -> Names -> PrettyPrintEnv +fromNames len names = PrettyPrintEnv terms' types' where + terms' r = shortestName . Set.map Name.convert $ Names.termName len r names + types' r = shortestName . Set.map Name.convert $ Names.typeName len r names + shortestName ns = safeHead $ HQ.sortByLength (toList ns) + +fromSuffixNames :: Int -> Names -> PrettyPrintEnv +fromSuffixNames len names = PrettyPrintEnv terms' types' where + terms' r = safeHead $ Names.suffixedTermName len r names + types' r = safeHead $ Names.suffixedTypeName len r names + +fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl +fromNamesDecl len names = + PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) + +-- -- A pair of PrettyPrintEnvs: +-- -- - suffixifiedPPE uses the shortest unique suffix +-- -- - unsuffixifiedPPE uses the shortest full name +-- -- +-- -- Generally, we want declarations LHS (the `x` in `x = 23`) to use the +-- -- unsuffixified names, so the LHS is an accurate description of where in the +-- -- namespace the definition lives. For everywhere else, we can use the +-- -- suffixified version. +-- data PrettyPrintEnvDecl = PrettyPrintEnvDecl { +-- unsuffixifiedPPE :: PrettyPrintEnv, +-- suffixifiedPPE :: PrettyPrintEnv +-- } deriving Show + +-- -- declarationPPE uses the full name for references that are +-- -- part the same cycle as the input reference, used to ensures +-- -- recursive definitions are printed properly, for instance: +-- -- +-- -- foo.bar x = foo.bar x +-- -- and not +-- -- foo.bar x = bar x +-- declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv +-- declarationPPE ppe rd = PrettyPrintEnv tm ty where +-- comp = Reference.members (Reference.componentFor rd) +-- tm r0@(Referent.Ref r) = if Set.member r comp +-- then terms (unsuffixifiedPPE ppe) r0 +-- else terms (suffixifiedPPE ppe) r0 +-- tm r = terms (suffixifiedPPE ppe) r +-- ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r +-- else types (suffixifiedPPE ppe) r + +-- -- Left-biased union of environments +-- unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv +-- unionLeft e1 e2 = PrettyPrintEnv +-- (\r -> terms e1 r <|> terms e2 r) +-- (\r -> types e1 r <|> types e2 r) + +-- assignTermName +-- :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv +-- assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) + +-- fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv +-- fromTypeNames types = +-- let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) + +-- fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv +-- fromTermNames tms = +-- let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) + +-- -- todo: these need to be a dynamic length, but we need additional info +-- todoHashLength :: Int +-- todoHashLength = 10 + +-- termName :: PrettyPrintEnv -> Referent -> HashQualified Name +-- termName env r = +-- fromMaybe (HQ.take todoHashLength $ HQ.fromReferent r) (terms env r) + +-- typeName :: PrettyPrintEnv -> Reference -> HashQualified Name +-- typeName env r = +-- fromMaybe (HQ.take todoHashLength $ HQ.fromReference r) (types env r) + +-- patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name +-- patternName env r cid = +-- case patterns env r cid of +-- Just name -> name +-- Nothing -> HQ.take todoHashLength $ HQ.fromPattern r cid + +-- instance Monoid PrettyPrintEnv where +-- mempty = PrettyPrintEnv (const Nothing) (const Nothing) +-- mappend = unionLeft +-- instance Semigroup PrettyPrintEnv where +-- (<>) = mappend + +-- -- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' +-- -- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. + +-- -- Note that a Suffix can include dots. +-- type Suffix = Text +-- -- Each member of a Prefix list is dot-free. +-- type Prefix = [Text] +-- -- Keys are FQNs, values are shorter names which are equivalent, thanks to use +-- -- statements that are in scope. +-- type Imports = Map Name Suffix + +-- -- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. +-- elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name +-- elideFQN imports hq = +-- let hash = HQ.toHash hq +-- name' = do name <- HQ.toName hq +-- let hit = fmap Name.unsafeFromText (Map.lookup name imports) +-- -- Cut out the "const id $" to get tracing of FQN elision attempts. +-- let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) +-- t (pure $ fromMaybe name hit) +-- in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs new file mode 100644 index 0000000000..c39a16721b --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs @@ -0,0 +1,110 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnv.Util where + +import Unison.Prelude + +import Unison.HashQualified ( HashQualified ) +import Unison.Name ( Name ) +import Unison.Names3 ( Names ) +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) +import Unison.Util.List (safeHead) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Unison.HashQualified as HQ +import qualified Unison.HashQualified' as HQ' +import qualified Unison.Name as Name +import qualified Unison.Names3 as Names +import Unison.PrettyPrintEnv +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl, suffixifiedPPE, unsuffixifiedPPE)) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent + +-- fromNames :: Int -> Names -> PrettyPrintEnv +-- fromNames len names = PrettyPrintEnv terms' types' where +-- terms' r = shortestName . Set.map HQ'.toHQ $ Names.termName len r names +-- types' r = shortestName . Set.map HQ'.toHQ $ Names.typeName len r names +-- shortestName ns = safeHead $ HQ.sortByLength (toList ns) + +-- fromSuffixNames :: Int -> Names -> PrettyPrintEnv +-- fromSuffixNames len names = fromNames len (Names.suffixify names) + +-- fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl +-- fromNamesDecl len names = +-- PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) + +-- declarationPPE uses the full name for references that are +-- part the same cycle as the input reference, used to ensures +-- recursive definitions are printed properly, for instance: +-- +-- foo.bar x = foo.bar x +-- and not +-- foo.bar x = bar x +declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv +declarationPPE ppe rd = PrettyPrintEnv tm ty where + comp = Reference.members (Reference.componentFor rd) + tm r0@(Referent.Ref r) = if Set.member r comp + then terms (unsuffixifiedPPE ppe) r0 + else terms (suffixifiedPPE ppe) r0 + tm r = terms (suffixifiedPPE ppe) r + ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r + else types (suffixifiedPPE ppe) r + +-- Left-biased union of environments +unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv +unionLeft e1 e2 = PrettyPrintEnv + (\r -> terms e1 r <|> terms e2 r) + (\r -> types e1 r <|> types e2 r) + +assignTermName + :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv +assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) + +fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv +fromTypeNames types = + let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) + +fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv +fromTermNames tms = + let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) + +-- todo: these need to be a dynamic length, but we need additional info +todoHashLength :: Int +todoHashLength = 10 + +-- termName :: PrettyPrintEnv -> Referent -> HashQualified Name +-- termName env r = +-- fromMaybe (HQ.take todoHashLength $ HQ.fromReferent r) (terms env r) + +-- typeName :: PrettyPrintEnv -> Reference -> HashQualified Name +-- typeName env r = +-- fromMaybe (HQ.take todoHashLength $ HQ.fromReference r) (types env r) + +patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name +patternName env r cid = + case patterns env r cid of + Just name -> name + Nothing -> HQ.take todoHashLength $ HQ.fromPattern r cid + +-- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' +-- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. + +-- Note that a Suffix can include dots. +type Suffix = Text +-- Each member of a Prefix list is dot-free. +type Prefix = [Text] +-- Keys are FQNs, values are shorter names which are equivalent, thanks to use +-- statements that are in scope. +type Imports = Map Name Suffix + +-- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. +elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name +elideFQN imports hq = + let hash = HQ.toHash hq + name' = do name <- HQ.toName hq + let hit = fmap Name.unsafeFromText (Map.lookup name imports) + -- Cut out the "const id $" to get tracing of FQN elision attempts. + let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) + t (pure $ fromMaybe name hit) + in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs new file mode 100644 index 0000000000..92b788d9ad --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs @@ -0,0 +1,18 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl(..)) where + +import Unison.PrettyPrintEnv (PrettyPrintEnv) + +-- A pair of PrettyPrintEnvs: +-- - suffixifiedPPE uses the shortest unique suffix +-- - unsuffixifiedPPE uses the shortest full name +-- +-- Generally, we want declarations LHS (the `x` in `x = 23`) to use the +-- unsuffixified names, so the LHS is an accurate description of where in the +-- namespace the definition lives. For everywhere else, we can use the +-- suffixified version. +data PrettyPrintEnvDecl = PrettyPrintEnvDecl { + unsuffixifiedPPE :: PrettyPrintEnv, + suffixifiedPPE :: PrettyPrintEnv + } deriving Show diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs new file mode 100644 index 0000000000..dedb5591bd --- /dev/null +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs @@ -0,0 +1,11 @@ +{-# Language OverloadedStrings #-} + +module Unison.PrettyPrintEnvDecl.Names where + +import Unison.Names3 (Names) +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl)) +import Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) + +fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl +fromNamesDecl len names = + PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 53d807f50c..d19b728ceb 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -24,9 +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 qualified Unison.Lexer.Pos as L import Unison.Name ( Name ) -import Unison.Parser (Ann (..), Annotated, ann) -import qualified Unison.Parser as Parser +import Unison.Parser (Annotated, ann) +import qualified Unison.Parser as Parser +import Unison.Parser.Ann (Ann (..)) import qualified Unison.Reference as R import Unison.Referent (Referent, pattern Ref) import Unison.Result (Note (..)) @@ -38,6 +40,7 @@ import qualified Unison.Typechecker.Context as C import Unison.Typechecker.TypeError import qualified Unison.Typechecker.TypeVar as TypeVar import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Error as UF import Unison.Util.AnnotatedText (AnnotatedText) import qualified Unison.Util.AnnotatedText as AT import Unison.Util.ColorText (Color) @@ -51,6 +54,7 @@ import qualified Unison.TermPrinter as TermPrinter import qualified Unison.Util.Pretty as Pr import Unison.Util.Pretty (Pretty, ColorText) import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name import Unison.HashQualified (HashQualified) import Unison.Type (Type) diff --git a/parser-typechecker/src/Unison/Result.hs b/parser-typechecker/src/Unison/Result.hs index c0569c9113..cd592ae34d 100644 --- a/parser-typechecker/src/Unison/Result.hs +++ b/parser-typechecker/src/Unison/Result.hs @@ -19,7 +19,7 @@ import Unison.Paths ( Path ) import Unison.Term ( Term ) import qualified Unison.Typechecker.Context as Context import Control.Error.Util ( note) -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names type Result notes = ResultT notes Identity diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index 1eac557f34..38864fe5bd 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -1,34 +1,53 @@ {-# language LambdaCase #-} {-# language BangPatterns #-} +{-# language PatternSynonyms #-} module Unison.Runtime.ANF.Serialize where +import Prelude hiding (putChar, getChar) + +import Basement.Block (Block) + +import Control.Applicative (liftA2) import Control.Monad +import Data.Bits (Bits) import Data.Bytes.Put import Data.Bytes.Get hiding (getBytes) +import qualified Data.Bytes.Get as Ser import Data.Bytes.VarInt import Data.Bytes.Serial +import Data.Bytes.Signed (Unsigned) import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.Foldable (traverse_) import Data.Functor ((<&>)) -import Data.Map as Map (Map, fromList, lookup) +import Data.Map as Map (Map, fromList, lookup, toList) import Data.Serialize.Put (runPutLazy) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Word (Word8, Word16, Word64) +import Data.Int (Int64) +import qualified Data.ByteArray as BA import qualified Data.Sequence as Seq import qualified Data.ByteString.Lazy as L import GHC.Stack -import Unison.Codebase.Serialization.V1 as V1 +import Unison.Hash (Hash) import Unison.Util.EnumContainers as EC -import Unison.Reference (Reference) +import Unison.Reference (Reference(..), pattern Derived, Id(..)) +import Unison.Referent (Referent, pattern Ref, pattern Con) import Unison.ABT.Normalized (Term(..)) import Unison.Runtime.Exception import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Var (Var(..), Type(ANFBlank)) +import qualified Unison.Util.Bytes as Bytes +import qualified Unison.Hash as Hash +import qualified Unison.ConstructorType as CT + data TmTag = VarT | ForceT | AppT | HandleT | ShiftT | MatchT | LitT @@ -49,6 +68,9 @@ data BLTag = TextT | ListT | TmLinkT | TyLinkT | BytesT data VaTag = PartialT | DataT | ContT | BLitT data CoTag = KET | MarkT | PushT +unknownTag :: String -> a +unknownTag t = exn $ "unknown " ++ t ++ " word" + class Tag t where tag2word :: t -> Word8 word2tag :: Word8 -> t @@ -78,7 +100,7 @@ instance Tag TmTag where 9 -> NameVarT 10 -> LetDirT 11 -> LetIndT - _ -> exn "unknown TmTag word" + _ -> unknownTag "TmTag" instance Tag FnTag where tag2word = \case @@ -96,7 +118,7 @@ instance Tag FnTag where 3 -> FConT 4 -> FReqT 5 -> FPrimT - _ -> exn "unknown FnTag word" + _ -> unknownTag "FnTag" instance Tag MtTag where tag2word = \case @@ -114,7 +136,7 @@ instance Tag MtTag where 3 -> MEmptyT 4 -> MDataT 5 -> MSumT - _ -> exn "unknown MtTag word" + _ -> unknownTag "MtTag" instance Tag LtTag where tag2word = \case @@ -134,7 +156,7 @@ instance Tag LtTag where 4 -> CT 5 -> LMT 6 -> LYT - _ -> exn "unknown LtTag word" + _ -> unknownTag "LtTag" instance Tag BLTag where tag2word = \case @@ -150,7 +172,7 @@ instance Tag BLTag where 2 -> TmLinkT 3 -> TyLinkT 4 -> BytesT - _ -> exn "unknown BLTag word" + t -> unknownTag "BLTag" t instance Tag VaTag where tag2word = \case @@ -164,7 +186,7 @@ instance Tag VaTag where 1 -> DataT 2 -> ContT 3 -> BLitT - _ -> exn "unknown VaTag word" + t -> unknownTag "VaTag" t instance Tag CoTag where tag2word = \case @@ -175,7 +197,7 @@ instance Tag CoTag where 0 -> KET 1 -> MarkT 2 -> PushT - _ -> exn "unknown CoTag word" + t -> unknownTag "CoTag" t putTag :: MonadPut m => Tag t => t -> m () putTag = putWord8 . tag2word @@ -402,7 +424,7 @@ putLit (I i) = putTag IT *> putInt i putLit (N n) = putTag NT *> putNat n putLit (F f) = putTag FT *> putFloat f putLit (T t) = putTag TT *> putText t -putLit (C c) = putTag CT *> V1.putChar c +putLit (C c) = putTag CT *> putChar c putLit (LM r) = putTag LMT *> putReferent r putLit (LY r) = putTag LYT *> putReference r @@ -412,7 +434,7 @@ getLit = getTag >>= \case NT -> N <$> getNat FT -> F <$> getFloat TT -> T <$> getText - CT -> C <$> V1.getChar + CT -> C <$> getChar LMT -> LM <$> getReferent LYT -> LY <$> getReference @@ -461,7 +483,7 @@ putBranches ctx bs = case bs of putTag MReqT putMap putReference (putEnumMap putCTag (putCase ctx)) m putNormal (v:ctx) df - where + where MatchData r m df -> do putTag MDataT putReference r @@ -605,3 +627,157 @@ serializeValue v = runPutS (putVersion *> putValue v) serializeValueLazy :: Value -> L.ByteString serializeValueLazy v = runPutLazy (putVersion *> putValue v) where putVersion = putWord32be 1 + +-- Some basics, moved over from V1 serialization +putChar :: MonadPut m => Char -> m () +putChar = serialize . VarInt . fromEnum + +getChar :: MonadGet m => m Char +getChar = toEnum . unVarInt <$> deserialize + +putFloat :: MonadPut m => Double -> m () +putFloat = serializeBE + +getFloat :: MonadGet m => m Double +getFloat = deserializeBE + +putNat :: MonadPut m => Word64 -> m () +putNat = putWord64be + +getNat :: MonadGet m => m Word64 +getNat = getWord64be + +putInt :: MonadPut m => Int64 -> m () +putInt = serializeBE + +getInt :: MonadGet m => m Int64 +getInt = deserializeBE + +putLength :: + (MonadPut m, Integral n, Integral (Unsigned n), + Bits n, Bits (Unsigned n)) + => n -> m () +putLength = serialize . VarInt + +getLength :: + (MonadGet m, Integral n, Integral (Unsigned n), + Bits n, Bits (Unsigned n)) + => m n +getLength = unVarInt <$> deserialize + +putFoldable + :: (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () +putFoldable putA as = do + putLength (length as) + traverse_ putA as + +putMap :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Map a b -> m () +putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m) + +getList :: MonadGet m => m a -> m [a] +getList a = getLength >>= (`replicateM` a) + +getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b) +getMap getA getB = Map.fromList <$> getList (getPair getA getB) + +putMaybe :: MonadPut m => Maybe a -> (a -> m ()) -> m () +putMaybe Nothing _ = putWord8 0 +putMaybe (Just a) putA = putWord8 1 *> putA a + +getMaybe :: MonadGet m => m a -> m (Maybe a) +getMaybe getA = getWord8 >>= \tag -> case tag of + 0 -> pure Nothing + 1 -> Just <$> getA + _ -> unknownTag "Maybe" tag + +putPair :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a,b) -> m () +putPair putA putB (a,b) = putA a *> putB b + +getPair :: MonadGet m => m a -> m b -> m (a,b) +getPair = liftA2 (,) + +getBytes :: MonadGet m => m Bytes.Bytes +getBytes = Bytes.fromChunks <$> getList getBlock + +putBytes :: MonadPut m => Bytes.Bytes -> m () +putBytes = putFoldable putBlock . Bytes.chunks + +getBlock :: MonadGet m => m (Bytes.View (Block Word8)) +getBlock = getLength >>= fmap (Bytes.view . BA.convert) . getByteString + +putBlock :: MonadPut m => Bytes.View (Block Word8) -> m () +putBlock b = putLength (BA.length b) *> putByteString (BA.convert b) + +putHash :: MonadPut m => Hash -> m () +putHash h = do + let bs = Hash.toBytes h + putLength (B.length bs) + putByteString bs + +getHash :: MonadGet m => m Hash +getHash = do + len <- getLength + bs <- B.copy <$> Ser.getBytes len + pure $ Hash.fromBytes bs + +putReferent :: MonadPut m => Referent -> m () +putReferent = \case + Ref r -> do + putWord8 0 + putReference r + Con r i ct -> do + putWord8 1 + putReference r + putLength i + putConstructorType ct + +getReferent :: MonadGet m => m Referent +getReferent = do + tag <- getWord8 + case tag of + 0 -> Ref <$> getReference + 1 -> Con <$> getReference <*> getLength <*> getConstructorType + _ -> unknownTag "getReferent" tag + +getConstructorType :: MonadGet m => m CT.ConstructorType +getConstructorType = getWord8 >>= \case + 0 -> pure CT.Data + 1 -> pure CT.Effect + t -> unknownTag "getConstructorType" t + +putConstructorType :: MonadPut m => CT.ConstructorType -> m () +putConstructorType = \case + CT.Data -> putWord8 0 + CT.Effect -> putWord8 1 + +putText :: MonadPut m => Text -> m () +putText text = do + let bs = encodeUtf8 text + putLength $ B.length bs + putByteString bs + +getText :: MonadGet m => m Text +getText = do + len <- getLength + bs <- B.copy <$> Ser.getBytes len + pure $ decodeUtf8 bs + +putReference :: MonadPut m => Reference -> m () +putReference r = case r of + Builtin name -> do + putWord8 0 + putText name + Derived hash i n -> do + putWord8 1 + putHash hash + putLength i + putLength n + +getReference :: MonadGet m => m Reference +getReference = do + tag <- getWord8 + case tag of + 0 -> Builtin <$> getText + 1 -> DerivedId <$> (Id <$> getHash <*> getLength <*> getLength) + _ -> unknownTag "Reference" tag + diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index 09e5604f51..23daf22226 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -14,12 +14,13 @@ import Data.List (elemIndex, genericIndex) import Text.RawString.QQ (r) import Unison.Codebase.CodeLookup (CodeLookup(..)) import Unison.FileParsers (parseAndSynthesizeFile) -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import Unison.Symbol (Symbol) import qualified Data.Map as Map import qualified Unison.Builtin as Builtin -import qualified Unison.Codebase.CodeLookup as CL +import qualified Unison.Codebase.CodeLookup.Util as CL import qualified Unison.DataDeclaration as DD +import qualified Unison.DataDeclaration.ConstructorId as DD import qualified Unison.Parser as Parser import qualified Unison.Reference as R import qualified Unison.Result as Result diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 4e3b371819..546c7c160a 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -43,7 +43,7 @@ import Unison.Codebase.CodeLookup (CodeLookup(..)) import Unison.Codebase.Runtime (Runtime(..), Error) import Unison.Codebase.MainTerm (builtinMain, builtinTest) -import Unison.Parser (Ann(External)) +import Unison.Parser.Ann (Ann(External)) import Unison.PrettyPrintEnv import Unison.Util.Pretty as P import Unison.Symbol (Symbol) @@ -334,5 +334,4 @@ startRuntime = do evalInContext ppe ctx init , mainType = builtinMain External , ioTestType = builtinTest External - , needsContainment = False } diff --git a/parser-typechecker/src/Unison/Runtime/Pattern.hs b/parser-typechecker/src/Unison/Runtime/Pattern.hs index 1c93466a2f..a8bae9a3fe 100644 --- a/parser-typechecker/src/Unison/Runtime/Pattern.hs +++ b/parser-typechecker/src/Unison/Runtime/Pattern.hs @@ -25,6 +25,7 @@ import Unison.ABT (absChain', visitPure, pattern AbsN', renames) import Unison.Builtin.Decls (builtinDataDecls, builtinEffectDecls) import Unison.DataDeclaration (declFields) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Pattern import qualified Unison.Pattern as P import Unison.Reference (Reference(..)) @@ -350,7 +351,7 @@ splitRowSeq -> [([P.Pattern v], PatternRow v)] splitRowSeq avoid0 v m r@(PR (break ((==v).loc) -> (pl, sp : pr)) g b) = case decomposeSeqP avoid m sp of - Cover sps -> + Cover sps -> [(sps, PR (pl ++ filter refutable sps ++ pr) g b)] Disjoint -> [] Overlap -> [([], r)] @@ -541,7 +542,7 @@ prepareAs p u = pure $ u <$ p preparePattern :: Var v => P.Pattern a -> PPM v (P.Pattern v) preparePattern p = prepareAs p =<< freshVar -buildPattern :: Bool -> Reference -> Int -> [v] -> Int -> P.Pattern () +buildPattern :: Bool -> Reference -> ConstructorId -> [v] -> Int -> P.Pattern () buildPattern effect r t vs nfields | effect, [] <- vps = internalBug "too few patterns for effect bind" | effect = P.EffectBind () r t (init vps) (last vps) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index d16a04f141..203ec78675 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -31,6 +31,8 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch, Branch0) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch +import qualified Unison.Codebase.Causal (RawHash(RawHash)) import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Metadata as Metadata import Unison.Codebase.Path (Path) @@ -57,9 +59,11 @@ import Unison.Names3 Names0, ) import qualified Unison.Names3 as Names3 -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.PrettyPrintEnvDecl.Names as PPE import Unison.Reference (Reference) import qualified Unison.Reference as Reference import Unison.Referent (Referent) @@ -87,6 +91,10 @@ import Unison.Var (Var) import qualified Unison.Server.Doc as Doc import qualified Unison.UnisonFile as UF import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject +import qualified Unison.WatchKind as WK +import qualified Unison.PrettyPrintEnv.Util as PPE + +type SyntaxText = UST.SyntaxText' Reference data ShallowListEntry v a = ShallowTermEntry (TermEntry v a) @@ -286,7 +294,7 @@ formatTypeName :: PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText formatTypeName ppe = fmap Syntax.convertElement . formatTypeName' ppe -formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> UST.SyntaxText +formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> SyntaxText formatTypeName' ppe r = Pretty.renderUnbroken . NP.styleHashQualified id $ @@ -547,7 +555,7 @@ expandShortBranchHash codebase hash = do _ -> throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet -formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> UST.SyntaxText +formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = Pretty.render w . TypePrinter.pretty0 ppe mempty (-1) @@ -601,7 +609,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod where rel = Names.terms $ currentNames parseNames f k _ = Set.fromList . fmap Name.toText . filter isAbsolute . toList - $ R.lookupRan (Referent.Ref' k) rel + $ R.lookupRan (Referent.Ref k) rel typeFqns :: Map Reference (Set Text) typeFqns = Map.mapWithKey f types where @@ -641,7 +649,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm lift $ case r of - Just tmr -> Codebase.putWatch codebase UF.RegularWatch + Just tmr -> Codebase.putWatch codebase WK.RegularWatch (Term.hashClosedTerm tm) (Term.amap (const mempty) tmr) Nothing -> pure () @@ -791,7 +799,7 @@ termsToSyntax -> Width -> PPE.PrettyPrintEnvDecl -> Map Reference.Reference (DisplayObject (Type v a) (Term v a)) - -> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText) + -> Map Reference.Reference (DisplayObject SyntaxText SyntaxText) termsToSyntax suff width ppe0 terms = Map.fromList . map go . Map.toList $ Map.mapKeys (first (PPE.termName ppeDecl . Referent.Ref) . dupe) @@ -816,7 +824,7 @@ typesToSyntax -> Width -> PPE.PrettyPrintEnvDecl -> Map Reference.Reference (DisplayObject () (DD.Decl v a)) - -> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText) + -> Map Reference.Reference (DisplayObject SyntaxText SyntaxText) typesToSyntax suff width ppe0 types = Map.fromList $ map go . Map.toList $ Map.mapKeys (first (PPE.typeName ppeDecl) . dupe) diff --git a/parser-typechecker/src/Unison/Server/CodebaseServer.hs b/parser-typechecker/src/Unison/Server/CodebaseServer.hs index 0940eabb00..bc92bff2f9 100644 --- a/parser-typechecker/src/Unison/Server/CodebaseServer.hs +++ b/parser-typechecker/src/Unison/Server/CodebaseServer.hs @@ -93,7 +93,7 @@ import qualified System.FilePath as FilePath import System.Random.Stateful (getStdGen, newAtomicGenM, uniformByteStringM) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Runtime as Rt -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Endpoints.GetDefinitions diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index 3dcde3a108..3b7fdc4b59 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -34,6 +34,7 @@ import qualified Unison.DataDeclaration as DD import qualified Unison.DeclPrinter as DeclPrinter import qualified Unison.NamePrinter as NP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.Runtime.IOSource as DD @@ -153,7 +154,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case source :: Term v () -> m SyntaxText source tm = (pure . formatPretty . TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped)) tm - goSignatures :: [Referent] -> m [P.Pretty S.SyntaxText] + goSignatures :: [Referent] -> m [P.Pretty (S.SyntaxText' Reference)] goSignatures rs = runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case Nothing -> pure ["🆘 codebase is missing type signature for these definitions"] Just types -> pure . fmap P.group $ @@ -184,9 +185,9 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case -- Link (Either Link.Type Doc2.Term) DD.Doc2SpecialFormLink e -> let ppe = PPE.suffixifiedPPE pped - tm :: Referent -> P.Pretty S.SyntaxText + tm :: Referent -> P.Pretty (S.SyntaxText' Reference) tm r = (NP.styleHashQualified'' (NP.fmt (S.Referent r)) . PPE.termName ppe) r - ty :: Reference -> P.Pretty S.SyntaxText + ty :: Reference -> P.Pretty (S.SyntaxText' Reference) ty r = (NP.styleHashQualified'' (NP.fmt (S.Reference r)) . PPE.typeName ppe) r in Link <$> case e of DD.EitherLeft' (Term.TypeLink' r) -> (pure . formatPretty . ty) r diff --git a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs index 7a03d7536e..22af872518 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -38,10 +38,11 @@ import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.HashQualified' as HQ' import Unison.NameSegment -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend import Unison.Server.Errors diff --git a/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs b/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs index d897bd3401..38c9019e8a 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs @@ -24,12 +24,13 @@ import Servant.Docs import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash ( ShortBranchHash, ) import qualified Unison.HashQualified as HQ -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend import Unison.Server.Errors diff --git a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs b/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs index 60a3095336..6a02d64daa 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs @@ -33,12 +33,13 @@ import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.Hash as Hash import qualified Unison.HashQualified as HQ import qualified Unison.Name as Name import qualified Unison.NameSegment as NameSegment -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Server.Backend as Backend diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index e25c88f5a9..beb57e63c7 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -39,6 +39,7 @@ import qualified Unison.Lexer as L import qualified Unison.Name as Name import qualified Unison.Names3 as Names import qualified Unison.Parser as Parser (seq, uniqueName) +import Unison.Parser.Ann (Ann) import qualified Unison.Pattern as Pattern import qualified Unison.Term as Term import qualified Unison.Type as Type diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index b61632550b..8d1410b4c1 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -31,7 +31,6 @@ import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import Unison.Referent ( Referent ) import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText ( SyntaxText ) import Unison.Term import Unison.Type ( Type ) import qualified Unison.Type as Type @@ -42,12 +41,15 @@ import qualified Unison.Util.Bytes as Bytes import Unison.Util.Monoid ( intercalateMap ) import qualified Unison.Util.Pretty as PP import Unison.Util.Pretty ( Pretty, ColorText, Width ) -import Unison.PrettyPrintEnv ( PrettyPrintEnv, Suffix, Prefix, Imports, elideFQN ) -import qualified Unison.PrettyPrintEnv as PrettyPrintEnv +import Unison.PrettyPrintEnv (PrettyPrintEnv) +import qualified Unison.PrettyPrintEnv as PrettyPrintEnv +import Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) import qualified Unison.Builtin.Decls as DD import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm') import qualified Unison.ConstructorType as CT +type SyntaxText = S.SyntaxText' Reference + pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText pretty env = PP.syntaxToColor . pretty0 env emptyAc . printAnnotate env diff --git a/parser-typechecker/src/Unison/TypeParser.hs b/parser-typechecker/src/Unison/TypeParser.hs index 4a37790b1b..8dab497b67 100644 --- a/parser-typechecker/src/Unison/TypeParser.hs +++ b/parser-typechecker/src/Unison/TypeParser.hs @@ -7,6 +7,7 @@ import Unison.Prelude import qualified Text.Megaparsec as P import qualified Unison.Lexer as L import Unison.Parser +import Unison.Parser.Ann (Ann(..)) import Unison.Type (Type) import qualified Unison.Type as Type import Unison.Var (Var) diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index 12677efa4c..21699fc493 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -9,19 +9,21 @@ import qualified Data.Map as Map import Unison.HashQualified (HashQualified) import Unison.Name ( Name ) import Unison.NamePrinter (styleHashQualified'') -import Unison.PrettyPrintEnv (PrettyPrintEnv, Imports, elideFQN) +import Unison.PrettyPrintEnv (PrettyPrintEnv) import qualified Unison.PrettyPrintEnv as PrettyPrintEnv -import Unison.Reference (pattern Builtin) +import Unison.PrettyPrintEnv.FQN (Imports, elideFQN) +import Unison.Reference (Reference, pattern Builtin) import Unison.Type import Unison.Util.Pretty (ColorText, Pretty, Width) import Unison.Util.ColorText (toPlain) import qualified Unison.Util.SyntaxText as S -import Unison.Util.SyntaxText (SyntaxText) import qualified Unison.Util.Pretty as PP import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Builtin.Decls as DD +type SyntaxText = S.SyntaxText' Reference + pretty :: forall v a . (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText pretty ppe = PP.syntaxToColor . prettySyntax ppe diff --git a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs index 2925e7c005..161bf50b46 100644 --- a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs +++ b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs @@ -3,7 +3,7 @@ module Unison.Typechecker.TypeLookup where import Unison.Prelude import Unison.Reference (Reference) -import Unison.Referent (Referent) +import Unison.Referent (Referent, ConstructorId) import Unison.Type (Type) import qualified Data.Map as Map import qualified Unison.ConstructorType as CT @@ -35,11 +35,11 @@ constructorType tl r = (const CT.Data <$> Map.lookup r (dataDecls tl)) <|> (const CT.Effect <$> Map.lookup r (effectDecls tl)) -typeOfDataConstructor :: TypeLookup v a -> Reference -> Int -> Maybe (Type v a) +typeOfDataConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a) typeOfDataConstructor tl r cid = go =<< Map.lookup r (dataDecls tl) where go dd = DD.typeOfConstructor dd cid -typeOfEffectConstructor :: TypeLookup v a -> Reference -> Int -> Maybe (Type v a) +typeOfEffectConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a) typeOfEffectConstructor tl r cid = go =<< Map.lookup r (effectDecls tl) where go dd = DD.typeOfConstructor (DD.toDataDecl dd) cid diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index ff23c3fd51..e35a17eb7f 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -3,8 +3,34 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -module Unison.UnisonFile where - +module Unison.UnisonFile + ( -- * UnisonFile + UnisonFile (..), + pattern UnisonFile, + allWatches, + dataDeclarations, + declsToTypeLookup, + dependencies, + effectDeclarations, + typecheckingTerm, + watchesOfKind, + + -- * TypecheckedUnisonFile + TypecheckedUnisonFile (..), + allTerms, + dataDeclarations', + discardTypes, + effectDeclarations', + hashConstructors, + hashTerms, + indexByReference, + lookupDecl, + nonEmpty, + termSignatureExternalLabeledDependencies, + topLevelComponents, + typecheckedUnisonFile, + ) +where import Unison.Prelude import Control.Lens @@ -17,9 +43,11 @@ import Unison.DataDeclaration (DataDeclaration) import Unison.DataDeclaration (EffectDeclaration(..)) import Unison.DataDeclaration (hashDecls) import qualified Unison.DataDeclaration as DD +import qualified Unison.DataDeclaration.Names as DD import qualified Unison.Builtin.Decls as DD import qualified Unison.Name as Name -import qualified Unison.Names3 as Names +-- import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent @@ -27,6 +55,7 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type +import Unison.UnisonFile.Type (UnisonFile(..), TypecheckedUnisonFile(..), pattern UnisonFile, pattern TypecheckedUnisonFile) import qualified Unison.Util.List as List import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as Relation @@ -37,20 +66,24 @@ import Unison.Names3 (Names0) import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) -- import qualified Unison.Typechecker.Components as Components - -data UnisonFile v a = UnisonFileId { - dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), - effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), - terms :: [(v, Term v a)], - watches :: Map WatchKind [(v, Term v a)] -} deriving Show - -pattern UnisonFile ds es tms ws <- - UnisonFileId (fmap (first Reference.DerivedId) -> ds) - (fmap (first Reference.DerivedId) -> es) - tms - ws -{-# COMPLETE UnisonFile #-} +import Unison.WatchKind (WatchKind, pattern TestWatch) +import qualified Unison.Codebase.CodeLookup as CL +import qualified Unison.Util.Set as Set +import Control.Monad.State (State, evalState, get) + +-- data UnisonFile v a = UnisonFileId { +-- dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), +-- effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), +-- terms :: [(v, Term v a)], +-- watches :: Map WatchKind [(v, Term v a)] +-- } deriving Show + +-- pattern UnisonFile ds es tms ws <- +-- UnisonFileId (fmap (first Reference.DerivedId) -> ds) +-- (fmap (first Reference.DerivedId) -> es) +-- tms +-- ws +-- {-# COMPLETE UnisonFile #-} dataDeclarations :: UnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId @@ -68,10 +101,6 @@ watchesOfOtherKinds kind uf = allWatches :: UnisonFile v a -> [(v, Term v a)] allWatches = join . Map.elems . watches -type WatchKind = Var.WatchKind -pattern RegularWatch = Var.RegularWatch -pattern TestWatch = Var.TestWatch - -- Converts a file to a single let rec with a body of `()`, for -- purposes of typechecking. typecheckingTerm :: (Var v, Monoid a) => UnisonFile v a -> Term v a @@ -88,16 +117,16 @@ uberTerm' :: (Var v, Monoid a) => UnisonFile v a -> Term v a -> Term v a uberTerm' uf body = Term.letRec' True (terms uf <> allWatches uf) $ body --- A UnisonFile after typechecking. Terms are split into groups by --- cycle and the type of each term is known. -data TypecheckedUnisonFile v a = - TypecheckedUnisonFileId { - dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), - effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), - topLevelComponents' :: [[(v, Term v a, Type v a)]], - watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], - hashTermsId :: Map v (Reference.Id, Term v a, Type v a) - } deriving Show +-- -- A UnisonFile after typechecking. Terms are split into groups by +-- -- cycle and the type of each term is known. +-- data TypecheckedUnisonFile v a = +-- TypecheckedUnisonFileId { +-- dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), +-- effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), +-- topLevelComponents' :: [[(v, Term v a, Type v a)]], +-- watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], +-- hashTermsId :: Map v (Reference.Id, Term v a, Type v a) +-- } deriving Show -- backwards compatibility with the old data type dataDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, DataDeclaration v a) @@ -107,13 +136,13 @@ effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId' hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Term v a, Type v a) hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId -{-# COMPLETE TypecheckedUnisonFile #-} -pattern TypecheckedUnisonFile ds es tlcs wcs hts <- - TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) - (fmap (first Reference.DerivedId) -> es) - tlcs - wcs - (fmap (over _1 Reference.DerivedId) -> hts) +-- {-# COMPLETE TypecheckedUnisonFile #-} +-- pattern TypecheckedUnisonFile ds es tlcs wcs hts <- +-- TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) +-- (fmap (first Reference.DerivedId) -> es) +-- tlcs +-- wcs +-- (fmap (over _1 Reference.DerivedId) -> hts) -- todo: this is confusing, right? -- currently: create a degenerate TypecheckedUnisonFile @@ -230,27 +259,6 @@ declsToTypeLookup uf = TL.TypeLookup mempty (wrangle (effectDeclarations uf)) where wrangle = Map.fromList . Map.elems -toNames :: Var v => UnisonFile v a -> Names0 -toNames uf = datas <> effects - where - datas = foldMap DD.dataDeclToNames' (Map.toList (dataDeclarationsId uf)) - effects = foldMap DD.effectDeclToNames' (Map.toList (effectDeclarationsId uf)) - -typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 -typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where - terms = Relation.fromList - [ (Name.fromVar v, Referent.Ref r) - | (v, (r, _, _)) <- Map.toList $ hashTerms uf ] - types = Relation.fromList - [ (Name.fromVar v, r) - | (v, r) <- Map.toList $ fmap fst (dataDeclarations' uf) - <> fmap fst (effectDeclarations' uf) ] - ctors = Relation.fromMap - . Map.mapKeys Name.fromVar - . fmap (fmap Reference.DerivedId) - . hashConstructors - $ uf - typecheckedUnisonFile0 :: Ord v => TypecheckedUnisonFile v a typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty @@ -266,9 +274,9 @@ hashConstructors :: forall v a. Ord v => TypecheckedUnisonFile v a -> Map v Referent.Id hashConstructors file = let ctors1 = Map.elems (dataDeclarationsId' file) >>= \(ref, dd) -> - [ (v, Referent.Con' ref i CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ] + [ (v, Referent.ConId ref i CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ] ctors2 = Map.elems (effectDeclarationsId' file) >>= \(ref, dd) -> - [ (v, Referent.Con' ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] + [ (v, Referent.ConId ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] in Map.fromList (ctors1 ++ ctors2) type CtorLookup = Map String (Reference, Int) @@ -300,72 +308,12 @@ constructorType :: Var v => UnisonFile v a -> Reference -> Maybe CT.ConstructorType constructorType = TL.constructorType . declsToTypeLookup -data Env v a = Env - -- Data declaration name to hash and its fully resolved form - { datasId :: Map v (Reference.Id, DataDeclaration v a) - -- Effect declaration name to hash and its fully resolved form - , effectsId :: Map v (Reference.Id, EffectDeclaration v a) - -- Naming environment - , names :: Names0 -} - -datas :: Env v a -> Map v (Reference, DataDeclaration v a) -datas = fmap (first Reference.DerivedId) . datasId - -effects :: Env v a -> Map v (Reference, EffectDeclaration v a) -effects = fmap (first Reference.DerivedId) . effectsId - -data Error v a - -- A free type variable that couldn't be resolved - = UnknownType v a - -- A variable which is both a data and an ability declaration - | DupDataAndAbility v a a - deriving (Eq,Ord,Show) - --- This function computes hashes for data and effect declarations, and --- also returns a function for resolving strings to (Reference, ConstructorId) --- for parsing of pattern matching --- --- If there are duplicate declarations, the duplicated names are returned on the --- left. -environmentFor - :: forall v a . Var v - => Names0 - -> Map v (DataDeclaration v a) - -> Map v (EffectDeclaration v a) - -> Names.ResolutionResult v a (Either [Error v a] (Env v a)) -environmentFor names dataDecls0 effectDecls0 = do - let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0 - -- data decls and hash decls may reference each other, and thus must be hashed together - dataDecls :: Map v (DataDeclaration v a) <- - traverse (DD.bindNames locallyBoundTypes names) dataDecls0 - effectDecls :: Map v (EffectDeclaration v a) <- - traverse (DD.withEffectDeclM (DD.bindNames locallyBoundTypes names)) effectDecls0 - let allDecls0 :: Map v (DataDeclaration v a) - allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) - hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- - hashDecls allDecls0 - -- then we have to pick out the dataDecls from the effectDecls - let - allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ] - dataDecls' = Map.difference allDecls effectDecls - effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls - -- ctor and effect terms - ctors = foldMap DD.dataDeclToNames' (Map.toList dataDecls') - effects = foldMap DD.effectDeclToNames' (Map.toList effectDecls') - names' = ctors <> effects - overlaps = let - w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed) - in Map.elems $ Map.intersectionWithKey w dataDecls effectDecls where - okVars = Map.keysSet allDecls0 - unknownTypeRefs = Map.elems allDecls0 >>= \dd -> - let cts = DD.constructorTypes dd - in cts >>= \ct -> [ UnknownType v a | (v,a) <- ABT.freeVarOccurrences mempty ct - , not (Set.member v okVars) ] - pure $ - if null overlaps && null unknownTypeRefs - then pure $ Env dataDecls' effectDecls' names' - else Left (unknownTypeRefs ++ overlaps) +-- data Error v a +-- -- A free type variable that couldn't be resolved +-- = UnknownType v a +-- -- A variable which is both a data and an ability declaration +-- | DupDataAndAbility v a a +-- deriving (Eq,Ord,Show) allVars :: Ord v => UnisonFile v a -> Set v allVars (UnisonFile ds es ts ws) = Set.unions @@ -375,4 +323,4 @@ allVars (UnisonFile ds es ts ws) = Set.unions , foldMap (DD.allVars . toDataDecl . snd) es , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- ts ] , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- join . Map.elems $ ws ] - ] + ] \ No newline at end of file diff --git a/parser-typechecker/src/Unison/UnisonFile/Env.hs b/parser-typechecker/src/Unison/UnisonFile/Env.hs new file mode 100644 index 0000000000..79a41e248d --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Env.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Env (Env(..), datas) where + +import Unison.Prelude + +import Data.Bifunctor (first) +import Unison.DataDeclaration (DataDeclaration) +import Unison.DataDeclaration (EffectDeclaration(..)) +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Names3 (Names0) + +data Env v a = Env + -- Data declaration name to hash and its fully resolved form + { datasId :: Map v (Reference.Id, DataDeclaration v a) + -- Effect declaration name to hash and its fully resolved form + , effectsId :: Map v (Reference.Id, EffectDeclaration v a) + -- Naming environment + , names :: Names0 +} + +datas :: Env v a -> Map v (Reference, DataDeclaration v a) +datas = fmap (first Reference.DerivedId) . datasId + +effects :: Env v a -> Map v (Reference, EffectDeclaration v a) +effects = fmap (first Reference.DerivedId) . effectsId diff --git a/parser-typechecker/src/Unison/UnisonFile/Error.hs b/parser-typechecker/src/Unison/UnisonFile/Error.hs new file mode 100644 index 0000000000..9c391ada2e --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Error.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Error where + +data Error v a + -- A free type variable that couldn't be resolved + = UnknownType v a + -- A variable which is both a data and an ability declaration + | DupDataAndAbility v a a + deriving (Eq,Ord,Show) + diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs new file mode 100644 index 0000000000..b882795012 --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Names where + +import Control.Lens +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import qualified Unison.Builtin.Decls as DD +import qualified Unison.ConstructorType as CT +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..), hashDecls) +import qualified Unison.DataDeclaration as DD +import qualified Unison.DataDeclaration.Names as DD.Names +import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.LabeledDependency as LD +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Names3 (Names0) +import qualified Unison.Names3 as Names +import Unison.Prelude +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.Typechecker.TypeLookup as TL +import Unison.UnisonFile.Env (Env(..)) +import Unison.UnisonFile.Error (Error (UnknownType, DupDataAndAbility)) +import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId), pattern UnisonFile) +import qualified Unison.UnisonFile as UF +import qualified Unison.UnisonFile.Error (pattern UnknownType, pattern DupDataAndAbility) +import qualified Unison.Util.List as List +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as Relation +import Unison.Var (Var) +import qualified Unison.Var as Var + +toNames :: Var v => UnisonFile v a -> Names0 +toNames uf = datas <> effects + where + datas = foldMap DD.Names.dataDeclToNames' (Map.toList (UF.dataDeclarationsId uf)) + effects = foldMap DD.Names.effectDeclToNames' (Map.toList (UF.effectDeclarationsId uf)) + +typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 +typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where + terms = Relation.fromList + [ (Name.fromVar v, Referent.Ref r) + | (v, (r, _, _)) <- Map.toList $ UF.hashTerms uf ] + types = Relation.fromList + [ (Name.fromVar v, r) + | (v, r) <- Map.toList $ fmap fst (UF.dataDeclarations' uf) + <> fmap fst (UF.effectDeclarations' uf) ] + ctors = Relation.fromMap + . Map.mapKeys Name.fromVar + . fmap (fmap Reference.DerivedId) + . UF.hashConstructors + $ uf + +typecheckedUnisonFile0 :: Ord v => TypecheckedUnisonFile v a +typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty + + +-- Substitutes free type and term variables occurring in the terms of this +-- `UnisonFile` using `externalNames`. +-- +-- Hash-qualified names are substituted during parsing, but non-HQ names are +-- substituted at the end of parsing, since they can be locally bound. Example, in +-- `x -> x + math.sqrt 2`, we don't know if `math.sqrt` is locally bound until +-- we are done parsing, whereas `math.sqrt#abc` can be resolved immediately +-- as it can't refer to a local definition. +bindNames :: Var v + => Names0 + -> UnisonFile v a + -> Names.ResolutionResult v a (UnisonFile v a) +bindNames names (UnisonFileId d e ts ws) = do + -- todo: consider having some kind of binding structure for terms & watches + -- so that you don't weirdly have free vars to tiptoe around. + -- The free vars should just be the things that need to be bound externally. + let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst) + termVarsSet = Set.fromList termVars + -- todo: can we clean up this lambda using something like `second` + ts' <- traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t) ts + ws' <- traverse (traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t)) ws + pure $ UnisonFileId d e ts' ws' + +-- This function computes hashes for data and effect declarations, and +-- also returns a function for resolving strings to (Reference, ConstructorId) +-- for parsing of pattern matching +-- +-- If there are duplicate declarations, the duplicated names are returned on the +-- left. +environmentFor + :: forall v a . Var v + => Names0 + -> Map v (DataDeclaration v a) + -> Map v (EffectDeclaration v a) + -> Names.ResolutionResult v a (Either [Error v a] (Env v a)) +environmentFor names dataDecls0 effectDecls0 = do + let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0 + -- data decls and hash decls may reference each other, and thus must be hashed together + dataDecls :: Map v (DataDeclaration v a) <- + traverse (DD.Names.bindNames locallyBoundTypes names) dataDecls0 + effectDecls :: Map v (EffectDeclaration v a) <- + traverse (DD.withEffectDeclM (DD.Names.bindNames locallyBoundTypes names)) effectDecls0 + let allDecls0 :: Map v (DataDeclaration v a) + allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) + hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- + hashDecls allDecls0 + -- then we have to pick out the dataDecls from the effectDecls + let + allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ] + dataDecls' = Map.difference allDecls effectDecls + effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls + -- ctor and effect terms + ctors = foldMap DD.Names.dataDeclToNames' (Map.toList dataDecls') + effects = foldMap DD.Names.effectDeclToNames' (Map.toList effectDecls') + names' = ctors <> effects + overlaps = let + w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed) + in Map.elems $ Map.intersectionWithKey w dataDecls effectDecls where + okVars = Map.keysSet allDecls0 + unknownTypeRefs = Map.elems allDecls0 >>= \dd -> + let cts = DD.constructorTypes dd + in cts >>= \ct -> [ UnknownType v a | (v,a) <- ABT.freeVarOccurrences mempty ct + , not (Set.member v okVars) ] + pure $ + if null overlaps && null unknownTypeRefs + then pure $ Env dataDecls' effectDecls' names' + else Left (unknownTypeRefs ++ overlaps) + +-- allVars :: Ord v => UnisonFile v a -> Set v +-- allVars (UnisonFile ds es ts ws) = Set.unions +-- [ Map.keysSet ds +-- , foldMap (DD.allVars . snd) ds +-- , Map.keysSet es +-- , foldMap (DD.allVars . toDataDecl . snd) es +-- , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- ts ] +-- , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- join . Map.elems $ ws ] +-- ] diff --git a/parser-typechecker/src/Unison/UnisonFile/Type.hs b/parser-typechecker/src/Unison/UnisonFile/Type.hs new file mode 100644 index 0000000000..218829ebfa --- /dev/null +++ b/parser-typechecker/src/Unison/UnisonFile/Type.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.UnisonFile.Type where + +import Unison.Prelude + +import Control.Lens +import Data.Bifunctor (first) +import Unison.DataDeclaration (DataDeclaration) +import Unison.DataDeclaration (EffectDeclaration(..)) +import qualified Unison.Reference as Reference +import Unison.Term (Term) +import Unison.Type (Type) +import Unison.WatchKind (WatchKind) + +data UnisonFile v a = UnisonFileId { + dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), + effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), + terms :: [(v, Term v a)], + watches :: Map WatchKind [(v, Term v a)] +} deriving Show + +pattern UnisonFile ds es tms ws <- + UnisonFileId (fmap (first Reference.DerivedId) -> ds) + (fmap (first Reference.DerivedId) -> es) + tms + ws +{-# COMPLETE UnisonFile #-} + +-- |A UnisonFile after typechecking. Terms are split into groups by +-- cycle and the type of each term is known. +data TypecheckedUnisonFile v a = + TypecheckedUnisonFileId { + dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), + effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), + topLevelComponents' :: [[(v, Term v a, Type v a)]], + watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], + hashTermsId :: Map v (Reference.Id, Term v a, Type v a) + } deriving Show + +{-# COMPLETE TypecheckedUnisonFile #-} +pattern TypecheckedUnisonFile ds es tlcs wcs hts <- + TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) + (fmap (first Reference.DerivedId) -> es) + tlcs + wcs + (fmap (over _1 Reference.DerivedId) -> hts) diff --git a/parser-typechecker/src/Unison/Util/AnnotatedText.hs b/parser-typechecker/src/Unison/Util/AnnotatedText.hs index f80ba6d01b..4f53462fe7 100644 --- a/parser-typechecker/src/Unison/Util/AnnotatedText.hs +++ b/parser-typechecker/src/Unison/Util/AnnotatedText.hs @@ -14,7 +14,7 @@ import qualified Data.Foldable as Foldable import qualified Data.Map as Map import Data.Sequence (Seq ((:|>), (:<|))) import qualified Data.Sequence as Seq -import Unison.Lexer (Line, Pos (..)) +import Unison.Lexer.Pos (Line, Pos (..)) import Unison.Util.Monoid (intercalateMap) import Unison.Util.Range (Range (..), inRange) import qualified Data.ListLike as LL diff --git a/parser-typechecker/src/Unison/Util/Convert.hs b/parser-typechecker/src/Unison/Util/Convert.hs new file mode 100644 index 0000000000..9bbba41472 --- /dev/null +++ b/parser-typechecker/src/Unison/Util/Convert.hs @@ -0,0 +1,10 @@ +module Unison.Util.Convert where + +class Convert a b where + convert :: a -> b + +class Parse a b where + parse :: a -> Maybe b + +instance (Parse a a2, Parse b b2) => Parse (a,b) (a2,b2) where + parse (a,b) = (,) <$> parse a <*> parse b diff --git a/parser-typechecker/src/Unison/Util/Menu.hs b/parser-typechecker/src/Unison/Util/Menu.hs deleted file mode 100644 index 90a49a907d..0000000000 --- a/parser-typechecker/src/Unison/Util/Menu.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} - -module Unison.Util.Menu (menu1, menuN, groupMenuN) where - -import Unison.Prelude - -import Data.List (find, isPrefixOf) -import qualified Data.Set as Set -import Data.Strings (strPadLeft) -import qualified Text.Read as Read -import Unison.Util.AnnotatedText (textEmpty) -import Unison.Util.ColorText (ColorText, toANSI) -import Unison.Util.Monoid (intercalateMap) --- utility - command line menus - -type Caption = ColorText -type Stylized = ColorText -type Keyword = String -type Console = IO String - -renderChoices :: forall a mc - . (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> (Keyword -> Bool) - -> Stylized -renderChoices render renderMeta groups metas isSelected = - showGroups <> showMetas - where - showGroups = intercalateMap "\n" format numberedGroups <> - if (not.null) groups && (not.null) metas then "\n\n" else "" - showMetas = intercalateMap "\n" (("["<>) . (<>"]") . renderMeta . snd) metas - numberedGroups :: [(([Keyword], [a]), Int)] - numberedGroups = zip groups [1..] - numberWidth = (1+) . floor @Double . logBase 10 . fromIntegral $ length groups - format :: (([Keyword], [a]), Int) -> Stylized - format ((keywords, as), number) = - intercalateMap - "\n" - (format1 number (length as) (any isSelected keywords)) - (zip as [0..]) - format1 :: Int -> Int -> Bool -> (a, Int) -> Stylized - format1 groupNumber groupSize isSelected (a, index) = - header <> bracket <> render a - where - header :: (Semigroup s, IsString s) => s - header = - (if representativeRow - then (if isSelected then "*" else " ") - <> fromString (strPadLeft ' ' numberWidth (show groupNumber)) - <> ". " - else fromString $ replicate (numberWidth + 3) ' ') - representativeRow :: Bool - representativeRow = index == (groupSize - 1) `div` 2 - bracket :: IsString s => s - bracket = - if maxGroupSize > 1 then - if groupSize == 1 then "╶" - else if index == 0 then "┌" - else if index < groupSize - 1 then "│" - else "└" - else "" - maxGroupSize = maximum (length . snd <$> groups) - - -{- - - - 1 ping - pong - 2 foo - 3 bar - - [cancel] - [help] - - >> ping - - -} - -menu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [(Keyword, a)] - -> [(Keyword, mc)] - -> Maybe Keyword - -> IO (Maybe (Either mc a)) -menu1 console caption render renderMeta groups metas initial = do - let groups' = [ ([k], [a]) | (k, a) <- groups ] - metas' = [ ([k], mc) | (k, mc) <- metas ] - groupMenu1 console caption render renderMeta groups' metas' initial >>= \case - Just (Right [a]) -> pure (Just (Right a)) - Just (Left mc) -> pure (Just (Left mc)) - Nothing -> pure Nothing - _ -> error "unpossible; by construction we should only get singleton lists back" - -_repeatMenu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Maybe Keyword - -> IO (Either mc [a]) -_repeatMenu1 console caption render renderMeta groups metas initial = - groupMenu1 console caption render renderMeta groups metas initial >>= \case - Just x -> pure x - Nothing -> _repeatMenu1 console caption render renderMeta groups metas initial - -groupMenu1 :: forall a mc - . Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Maybe Keyword - -> IO (Maybe (Either mc [a])) -groupMenu1 console caption render renderMeta groups metas initial = do - when ((not . textEmpty) caption) $ do - print . toANSI $ caption - putStrLn "" - print . toANSI $ renderChoices render renderMeta groups metas (`elem` initial) - resume - where - restart = groupMenu1 console caption render renderMeta groups metas initial - -- restart with an updated caption - restart' caption groups metas initial = - groupMenu1 console caption render renderMeta groups metas initial - resume = do - putStr "\n>> " - input <- console - case words input of - [] -> useExistingSelections groups initial - input : _ -> case Read.readMaybe input of - Just i -> pickGroupByNumber i - Nothing -> pickGroupByPrefix input - where - pickGroupByNumber :: Int -> IO (Maybe (Either mc [a])) - pickGroupByNumber i = case atMay groups (i-1) of - Nothing -> do - putStrLn $ "Please pick a number from 1 to " ++ - show (length groups) ++ "." - restart - Just (_keywords, as) -> pure (Just (Right as)) - pickGroupByPrefix :: String -> IO (Maybe (Either mc [a])) - pickGroupByPrefix s = case matchingItems groups metas s of - ([],[]) -> do - putStrLn $ "Sorry, '" ++ s ++ "' didn't match anything." - resume - ([(_, as)],[]) -> pure (Just (Right as)) - ([], [(_, mc)]) -> pure (Just (Left mc)) - (groups, metas) -> - restart' - "Please clarify your selection, or press Enter to back up:" - groups metas Nothing >>= \case - Nothing -> restart - x -> pure x - matchingItems :: - forall a mc. [([Keyword], [a])] -> [([Keyword], mc)] -> String - -> ([([Keyword], [a])], [([Keyword], mc)]) - matchingItems groups metas s = - (filter (any (s `isPrefixOf`) . fst) groups - ,filter (any (s `isPrefixOf`) . fst) metas) - useExistingSelections :: - [([Keyword], [a])] -> Maybe Keyword -> IO (Maybe (Either mc [a])) - useExistingSelections groups initial = case initial of - Nothing -> pure Nothing - Just initial -> - case findMatchingGroup [initial] groups of - Just group -> pure (Just (Right group)) - Nothing -> error $ - "Default selection \"" ++ show initial ++ "\"" ++ - " not found in choice groups:\n" ++ show (fst <$> groups) - findMatchingGroup :: forall a. [Keyword] -> [([Keyword], [a])] -> Maybe [a] - findMatchingGroup initials groups = - snd <$> find (\(keywords, _as) -> any (`elem` keywords) initials) groups - - -{- - - - 1 ping - pong - 2 foo - 3 bar - - [all] - [cancel] - [help] - - >> 1 3 - >> * - - -} -menuN :: Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> [Keyword] - -> IO (Either mc [[a]]) -menuN _console _caption _render _renderMeta _groups _metas _initials = pure (Right []) - -groupMenuN :: forall a mc. Ord a - => Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> [[Keyword]] - -> IO (Either mc [[a]]) -groupMenuN console caption render renderMeta groups metas initials = - groupMenuN' console caption render renderMeta groups metas (Set.fromList initials) - -groupMenuN' :: forall a mc. Ord a - => Console - -> Caption - -> (a -> Stylized) - -> (mc -> Stylized) - -> [([Keyword], [a])] - -> [([Keyword], mc)] - -> Set [Keyword] - -> IO (Either mc [[a]]) -groupMenuN' console caption render renderMeta groups metas initials = do - when ((not . textEmpty) caption) $ do - print . toANSI $ caption - putStrLn "" - print . toANSI $ renderChoices render renderMeta groups metas ((`any` initials) . elem) - resume initials - where - restart initials = groupMenuN' console caption render renderMeta groups metas initials - -- restart with an updated caption - restart' caption groups metas initials = - groupMenuN' console caption render renderMeta groups metas initials - resume :: Set [Keyword] -> IO (Either mc [[a]]) - resume initials = do - putStr "\n>> " - input <- console - case words input of - [] -> useExistingSelections groups initials - input : _ -> case Read.readMaybe input of - Just i -> pickGroupByNumber i - Nothing -> pickGroupByPrefix input - where - pickGroupByNumber :: Int -> IO (Either mc [[a]]) - pickGroupByNumber i = case atMay groups (i-1) of - Nothing -> do - putStrLn $ "Please pick a number from 1 to " ++ - show (length groups) ++ "." - restart initials - Just (kw, _) -> restart (Set.insert kw initials) - pickGroupByPrefix :: String -> IO (Either mc [[a]]) - pickGroupByPrefix s = case matchingItems groups metas s of - ([],[]) -> do - putStrLn $ "Sorry, '" ++ s ++ "' didn't match anything." - resume initials - ([], [(_, mc)]) -> pure (Left mc) - ([(kw, _)],[]) -> restart (Set.insert kw initials) - (_, _) -> - restart' - "Your prefix matched both groups and commands; please choose by number or use a longer prefix:" - groups metas initials - matchingItems :: - forall a mc. [([Keyword], [a])] -> [([Keyword], mc)] -> String - -> ([([Keyword], [a])], [([Keyword], mc)]) - matchingItems groups metas s = - (filter (any (s `isPrefixOf`) . fst) groups - ,filter (any (s `isPrefixOf`) . fst) metas) - useExistingSelections :: - [([Keyword], [a])] -> Set [Keyword] -> IO (Either mc [[a]]) - useExistingSelections groups initials = pure . pure $ - foldr go [] initials where - go kws selections = case findMatchingGroup kws groups of - Just as -> as : selections - Nothing -> selections - findMatchingGroup :: forall a. [Keyword] -> [([Keyword], [a])] -> Maybe [a] - findMatchingGroup initials groups = - snd <$> find (\(keywords, _as) -> any (`elem` keywords) initials) groups diff --git a/parser-typechecker/src/Unison/Util/Pretty.hs b/parser-typechecker/src/Unison/Util/Pretty.hs index e8f1efeed6..0e72d2ce31 100644 --- a/parser-typechecker/src/Unison/Util/Pretty.hs +++ b/parser-typechecker/src/Unison/Util/Pretty.hs @@ -269,7 +269,7 @@ toHTML cssPrefix avail p = CT.toHTML cssPrefix (render avail p) toPlainUnbroken :: Pretty ColorText -> String toPlainUnbroken p = CT.toPlain (renderUnbroken p) -syntaxToColor :: Pretty ST.SyntaxText -> Pretty ColorText +syntaxToColor :: Pretty (ST.SyntaxText' r) -> Pretty ColorText syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors -- set the syntax, overriding any present syntax diff --git a/parser-typechecker/src/Unison/Util/Range.hs b/parser-typechecker/src/Unison/Util/Range.hs index e2377bc027..93c76dea07 100644 --- a/parser-typechecker/src/Unison/Util/Range.hs +++ b/parser-typechecker/src/Unison/Util/Range.hs @@ -1,6 +1,6 @@ module Unison.Util.Range where -import Unison.Lexer (Pos(..)) +import Unison.Lexer.Pos (Pos(..)) -- | True if `_x` contains `_y` contains :: Range -> Range -> Bool diff --git a/parser-typechecker/src/Unison/Util/SyntaxText.hs b/parser-typechecker/src/Unison/Util/SyntaxText.hs index 76f10bb109..cc2e4bb820 100644 --- a/parser-typechecker/src/Unison/Util/SyntaxText.hs +++ b/parser-typechecker/src/Unison/Util/SyntaxText.hs @@ -4,14 +4,12 @@ module Unison.Util.SyntaxText where import Unison.Prelude import Unison.Name (Name) -import Unison.Reference (Reference) -import Unison.Referent (Referent') +import Unison.Referent' (Referent') import Unison.HashQualified (HashQualified) import Unison.Pattern (SeqOp) import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate, segment) -type SyntaxText = SyntaxText' Reference type SyntaxText' r = AnnotatedText (Element r) -- The elements of the Unison grammar, for syntax highlighting purposes diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index 7a32d22650..87fc4ddf5b 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -10,9 +10,7 @@ import qualified Unison.Core.Test.Name as Name import qualified Unison.Test.ABT as ABT import qualified Unison.Test.Cache as Cache import qualified Unison.Test.ClearCache as ClearCache -import qualified Unison.Test.Codebase as Codebase import qualified Unison.Test.Codebase.Causal as Causal -import qualified Unison.Test.Codebase.FileCodebase as FileCodebase import qualified Unison.Test.Codebase.Path as Path import qualified Unison.Test.ColorText as ColorText import qualified Unison.Test.DataDeclaration as DataDeclaration @@ -38,7 +36,6 @@ import qualified Unison.Test.ANF as ANF import qualified Unison.Test.MCode as MCode import qualified Unison.Test.VersionParser as VersionParser import qualified Unison.Test.GitSync as GitSync -import qualified Unison.Test.Codebase.Upgrade12 as Upgrade12 -- import qualified Unison.Test.BaseUpgradePushPullTest as BaseUpgradePushPullTest test :: Test () @@ -60,19 +57,15 @@ test = tests , Path.test , Causal.test , Referent.test - , FileCodebase.test , ABT.test , ANF.test , MCode.test , Var.test - , Codebase.test , ClearCache.test , Typechecker.test , UriParser.test , Context.test - , Upgrade12.test , GitSync.test - -- , BaseUpgradePushPullTest.test -- slowwwwww test involving upgrading base, hard-coded to arya's filesystem , Name.test , VersionParser.test , Pretty.test diff --git a/parser-typechecker/tests/Unison/Test/ABT.hs b/parser-typechecker/tests/Unison/Test/ABT.hs index 2f36c15450..69daf20e1a 100644 --- a/parser-typechecker/tests/Unison/Test/ABT.hs +++ b/parser-typechecker/tests/Unison/Test/ABT.hs @@ -8,7 +8,7 @@ import Unison.ABT as ABT import Unison.Symbol (Symbol(..)) import Unison.Var as Var import Unison.Codebase.Serialization ( getFromBytes, putBytes ) -import qualified Unison.Codebase.Serialization.V1 as V1 +-- import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 test :: Test () test = scope "abt" $ tests [ @@ -30,14 +30,7 @@ test = scope "abt" $ tests [ -- make sure the variable wasn't captured expectEqual fvs [symbol 0 "a"] -- make sure the resulting term is alpha equiv to \a1 -> [a1, a] - expectEqual t2 (ABT.abs (symbol 0 "b") (ABT.tm [var 0 "b", var 0 "a"])), - - -- confirmation of fix for https://github.com/unisonweb/unison/issues/1388 - -- where symbols with nonzero freshIds did not round trip - scope "putSymbol" $ let - v = Symbol 10 (User "hi") - v' = getFromBytes V1.getSymbol (putBytes V1.putSymbol v) - in expectEqual (Just v) v' + expectEqual t2 (ABT.abs (symbol 0 "b") (ABT.tm [var 0 "b", var 0 "a"])) ] where symbol i n = Symbol i (Var.User n) diff --git a/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs b/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs deleted file mode 100644 index a3b833f2d2..0000000000 --- a/parser-typechecker/tests/Unison/Test/BaseUpgradePushPullTest.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Test.BaseUpgradePushPullTest where - -import Data.String.Here.Interpolated (i) -import EasyTest -import Shellmet () -import qualified Unison.Test.Ucm as Ucm -import Unison.Test.GitSync (initGitRepo) - --- keep it off for CI, since the random temp dirs it generates show up in the --- output, which causes the test output to change, and the "no change" check --- to fail -writeTranscriptOutput :: Bool -writeTranscriptOutput = False - -test :: Test () -test = scope "base-upgrade-push-pull-test" do - io do - v1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - putStrLn =<< Ucm.runTranscript v1 [i| - ```ucm - .> pull /Users/arya/base _base - ``` - |] - v2 <- Ucm.upgradeCodebase v1 - repo <- initGitRepo - putStrLn =<< Ucm.runTranscript v2 [i| - ```ucm - .> push ${repo} _base - ``` - |] - v2' <- Ucm.initCodebase Ucm.CodebaseFormat2 - putStrLn $ show v2' - putStrLn =<< Ucm.runTranscript v2' [i| - ```ucm - .> pull ${repo} _base - .> test - ``` - |] - ok diff --git a/parser-typechecker/tests/Unison/Test/ClearCache.hs b/parser-typechecker/tests/Unison/Test/ClearCache.hs index 64bb1d4fcb..9538401b97 100644 --- a/parser-typechecker/tests/Unison/Test/ClearCache.hs +++ b/parser-typechecker/tests/Unison/Test/ClearCache.hs @@ -9,7 +9,7 @@ import Data.String.Here (i) import EasyTest import qualified Unison.Codebase as Codebase import qualified Unison.Test.Ucm as Ucm -import qualified Unison.Var as WatchKind +import qualified Unison.WatchKind as WatchKind test :: Test () test = scope "clearWatchCache" $ diff --git a/parser-typechecker/tests/Unison/Test/Codebase.hs b/parser-typechecker/tests/Unison/Test/Codebase.hs deleted file mode 100644 index ad46c853b6..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# Language OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Test.Codebase where - -import Data.Functor.Identity -import qualified Data.Map as Map -import Data.Map ( (!) ) -import EasyTest -import qualified Unison.Codebase as Codebase -import Unison.Codebase.CodeLookup ( CodeLookup(..) ) -import qualified Unison.Hash as Hash -import qualified Unison.Reference as R -import Unison.Symbol ( Symbol ) -import qualified Unison.Term as Term -import qualified Unison.UnisonFile as UF -import qualified Unison.Var as Var - -test :: Test () -test = scope "codebase" $ tests - [ scope "makeSelfContained" $ - let h = Hash.unsafeFromBase32Hex "abcd" - ref = R.Derived h 0 1 - v1 = Var.refNamed @Symbol ref - foo = Var.named "foo" - -- original binding: `foo = \v1 -> ref` - binding = (foo, Term.lam () v1 (Term.ref () ref)) - uf = UF.UnisonFileId mempty mempty [binding] mempty - code :: CodeLookup Symbol Identity () - code = CodeLookup - { getTerm = \rid -> pure $ - if R.DerivedId rid == ref then Just (Term.int () 42) - else Nothing - , getTypeDeclaration = \_ -> pure Nothing - } - -- expected binding after makeSelfContained: `foo = \v1 -> v2`, where `v2 /= v1` - UF.UnisonFile _ _ (Map.fromList -> bindings) _ = runIdentity $ Codebase.makeSelfContained' code uf - Term.LamNamed' _ (Term.Var' v2) = bindings ! foo - in expect $ v2 /= v1 - ] diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs index 2aa192a949..9681a2bea4 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs @@ -10,6 +10,7 @@ import Unison.Codebase.Causal ( Causal(Cons, Merge) , before ) import qualified Unison.Codebase.Causal as Causal +import qualified Unison.Codebase.Causal.FoldHistory as Causal import Control.Monad.Trans.State (State, state, put) import Data.Int (Int64) import qualified Data.Map as Map diff --git a/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs b/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs deleted file mode 100644 index 147477b48c..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase/FileCodebase.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Unison.Test.Codebase.FileCodebase where - -import EasyTest -import Unison.Codebase.FileCodebase.Common (encodeFileName, decodeFileName) -import qualified Data.Set as Set -import Data.Char as Char -import Data.Foldable (toList) - -test :: Test () -test = scope "FileCodebase" . tests $ - [ scope "encode/decodeFileName" . tests $ - [ encodeDecode "abc" - , encodeDecode "👍" - , encodeDecode "\xfff" - , tests $ encodeDecode . (:[]) <$> ['!'..'~'] - , encodeDecode ("Universal." ++ ['!'..'~']) - , specialEncode "." - , specialEncode ".." - , tests $ map specialEncodeChar (toList specificallyBadChars) - , specialEncodeChar '👍' - , specialEncodeChar '\xfff' - ] - ] - -specialEncode :: String -> Test () -specialEncode s = - scope (" " <> s <> " gets special encoding") $ expect (encodeFileName s /= s) - -specialEncodeChar :: Char -> Test () -specialEncodeChar = specialEncode . pure - -encodeDecode :: String -> Test () -encodeDecode s = - let e = encodeFileName s - d = decodeFileName e - in scope s $ expect $ d == s && all isSafeChar e - --- In the past we had considered a much smaller set of safe chars: --- [0-9,a-z,A-Z,-._] from https://superuser.com/a/748264 --- Currently we are going by https://superuser.com/a/358861 -isSafeChar :: Char -> Bool -isSafeChar c = Set.notMember c specificallyBadChars - && Char.isPrint c - && Char.isAscii c - -specificallyBadChars :: Set.Set Char -specificallyBadChars = Set.fromList "\\/:*?\"<>|" - diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index e775fb489f..8776697843 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -4,6 +4,7 @@ module Unison.Test.Codebase.Path where import EasyTest import Unison.Codebase.Path +import Unison.Codebase.Path.Parse import Data.Sequence import Data.Text import Unison.NameSegment diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs b/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs deleted file mode 100644 index 506564add7..0000000000 --- a/parser-typechecker/tests/Unison/Test/Codebase/Upgrade12.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - - -module Unison.Test.Codebase.Upgrade12 (test) where - -import Data.Functor (void) -import Data.String.Here.Interpolated (i) -import EasyTest (Test, expectJust, io, ok, scope, tests) -import Shellmet () -import qualified Unison.Codebase as Codebase -import qualified Unison.Test.Ucm as Ucm -import Unison.UnisonFile (pattern TestWatch) -import Debug.Trace (traceShowM) - -test :: Test () -test = scope "codebase.upgrade12" $ tests [ - scope "typeAlias" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - .> history - .> history builtin - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```unison - x : Nat - x = 3 - ``` - |] - ok, - - scope "topLevelTerm" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> find - ``` - ```unison - > y - ``` - |] - ok, - - scope "metadataForTerm" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 "" - Ucm.runTranscript c1 [i| - ```unison:hide - doc = "y is the number 3" - y = 3 - ``` - ```ucm - .> debug.file - .> add - .> link doc y - .> links y - .> history - ``` - |] - -- 8bbb doc - -- mps7 y - -- ttjf post-link - -- 988m pre-link - -- 7asf empty - Ucm.runTranscript c1 [i| - ```ucm - .> links y - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> links y - ``` - |] - ok, - - scope "metadataForType" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison:hide - doc = "Nat means natural number" - ``` - ```ucm - .> add - .> alias.type ##Nat Nat - .> link doc Nat - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> links Nat - ``` - |] - ok, - - scope "subNamespace" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison - unique type a.b.C = C Nat - ``` - ```ucm - .> add - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> find - ``` - ```unison - > a.b.C.C 3 - ``` - |] - ok, - - scope "accessPatch" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison:hide - unique type A = A Nat - foo = A.A 3 - ``` - ```ucm - .> debug.file - .> add - ``` - ```unison:hide - unique type A = A Nat Nat - foo = A.A 3 3 - ``` - ```ucm - .> debug.file - .> update - ``` - ```ucm - .> view.patch patch - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> view.patch patch - ``` - |] - ok, - --- #00k3c9bp6m A --- #6v94dtbfk1 foo --- #d3bn4dqp1a A' --- #p3a21bjjl4 foo' - - scope "history" do - void $ io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```unison - foo = 3 - ``` - ```ucm - .> add - ``` - ```unison - foo = 4 - ``` - ```ucm - .> update - .> history - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - Ucm.runTranscript c2 [i| - ```ucm - .> history - .> reset-root #dsh - .> history - ``` - |] - ok, - - scope "test-watches" do - (watchTerms1, watchTerms2) <- io do - c1 <- Ucm.initCodebase Ucm.CodebaseFormat1 - Ucm.runTranscript c1 [i| - ```ucm - .> builtins.merge - ``` - ```unison - test> pass = [Ok "Passed"] - ``` - ```ucm - .> add - ``` - |] - (watches1, watchTerms1) <- Ucm.lowLevel c1 \c1' -> do - watches1@(_:_) <- Codebase.watches c1' TestWatch - watchTerms1 <- traverse (Codebase.getWatch c1' TestWatch) watches1 - pure (watches1, watchTerms1) - Ucm.runTranscript c1 [i| - ```unison - test> pass = [Ok "Passed"] - ``` - |] - c2 <- Ucm.upgradeCodebase c1 - watchTerms2 <- Ucm.lowLevel c2 \c2' -> - traverse (Codebase.getWatch c2' TestWatch) watches1 - traceShowM watches1 - traceShowM watchTerms1 - traceShowM watchTerms2 - pure (watchTerms1, watchTerms2) - expectJust (sequence watchTerms1) - expectJust (sequence watchTerms2) - ok - ] diff --git a/parser-typechecker/tests/Unison/Test/Common.hs b/parser-typechecker/tests/Unison/Test/Common.hs index 2c078fdb3b..46517fdefe 100644 --- a/parser-typechecker/tests/Unison/Test/Common.hs +++ b/parser-typechecker/tests/Unison/Test/Common.hs @@ -12,7 +12,7 @@ import Data.Sequence (Seq) import qualified Data.Text as Text import qualified Unison.Builtin as B import qualified Unison.FileParsers as FP -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import Unison.PrintError ( prettyParseError ) import Unison.Result (Result, Note) import Unison.Symbol (Symbol) diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 40824ecb50..84b2681320 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -9,14 +9,17 @@ import Text.RawString.QQ import qualified Unison.DataDeclaration as DD import Unison.DataDeclaration ( DataDeclaration(..), Decl, hashDecls ) import qualified Unison.Hash as Hash -import Unison.Parser ( Ann ) +import Unison.Parser.Ann (Ann) import Unison.Parsers ( unsafeParseFile ) +import Unison.Reference (Reference) import qualified Unison.Reference as R import Unison.Symbol ( Symbol ) import qualified Unison.Test.Common as Common import qualified Unison.Type as Type import Unison.UnisonFile ( UnisonFile(..) ) +import Unison.Var (Var) import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var test :: Test () test = scope "datadeclaration" $ diff --git a/parser-typechecker/tests/Unison/Test/FileParser.hs b/parser-typechecker/tests/Unison/Test/FileParser.hs index f45a6298a6..89a8813c58 100644 --- a/parser-typechecker/tests/Unison/Test/FileParser.hs +++ b/parser-typechecker/tests/Unison/Test/FileParser.hs @@ -8,6 +8,7 @@ module Unison.Test.FileParser where import qualified Text.Megaparsec.Error as MPE import Unison.FileParser (file) import qualified Unison.Parser as P + import qualified Unison.Parser.Ann as P import Unison.Parsers (unsafeGetRightFrom, unsafeParseFileBuiltinsOnly) import Unison.Symbol (Symbol) import Unison.UnisonFile (UnisonFile) diff --git a/parser-typechecker/tests/Unison/Test/GitSync.hs b/parser-typechecker/tests/Unison/Test/GitSync.hs index d38ba9af22..c5741d85a5 100644 --- a/parser-typechecker/tests/Unison/Test/GitSync.hs +++ b/parser-typechecker/tests/Unison/Test/GitSync.hs @@ -15,12 +15,12 @@ import System.FilePath (()) import qualified System.IO.Temp as Temp import qualified Unison.Codebase as Codebase import Unison.Codebase (Codebase) -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Symbol (Symbol) import Unison.Test.Ucm (CodebaseFormat, Transcript) import qualified Unison.Test.Ucm as Ucm -import Unison.UnisonFile (pattern TestWatch) +import Unison.WatchKind (pattern TestWatch) -- keep it off for CI, since the random temp dirs it generates show up in the -- output, which causes the test output to change, and the "no change" check @@ -33,7 +33,7 @@ test = scope "gitsync22" . tests $ fastForwardPush : nonFastForwardPush : destroyedRemote : - flip map [(Ucm.CodebaseFormat1 , "fc"), (Ucm.CodebaseFormat2, "sc")] + flip map [(Ucm.CodebaseFormat2, "sc")] \(fmt, name) -> scope name $ tests [ pushPullTest "typeAlias" fmt (\repo -> [i| diff --git a/parser-typechecker/tests/Unison/Test/Term.hs b/parser-typechecker/tests/Unison/Test/Term.hs index 5afdad551d..14b39e34df 100644 --- a/parser-typechecker/tests/Unison/Test/Term.hs +++ b/parser-typechecker/tests/Unison/Test/Term.hs @@ -11,6 +11,7 @@ import Unison.Symbol ( Symbol ) import qualified Unison.Term as Term import qualified Unison.Type as Type import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var test :: Test () test = scope "term" $ tests diff --git a/parser-typechecker/tests/Unison/Test/TermPrinter.hs b/parser-typechecker/tests/Unison/Test/TermPrinter.hs old mode 100755 new mode 100644 index fbf419dbc0..5b67107a04 --- a/parser-typechecker/tests/Unison/Test/TermPrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TermPrinter.hs @@ -12,9 +12,10 @@ import Unison.TermPrinter import qualified Unison.Type as Type import Unison.Symbol (Symbol, symbol) import qualified Unison.Builtin -import Unison.Parser (Ann(..)) +import Unison.Parser.Ann (Ann(..)) import qualified Unison.Util.Pretty as PP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.Util.ColorText as CT import Unison.Test.Common (t, tm) import qualified Unison.Test.Common as Common diff --git a/parser-typechecker/tests/Unison/Test/TypePrinter.hs b/parser-typechecker/tests/Unison/Test/TypePrinter.hs old mode 100755 new mode 100644 index 0c03f8ad0c..7f7fea7fba --- a/parser-typechecker/tests/Unison/Test/TypePrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TypePrinter.hs @@ -7,6 +7,7 @@ import qualified Unison.Builtin import Unison.Util.ColorText (toPlain) import qualified Unison.Util.Pretty as PP import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.Test.Common as Common diff --git a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs index 5c4b90adb6..239abb65d6 100644 --- a/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs +++ b/parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs @@ -5,7 +5,7 @@ module Unison.Test.Typechecker.TypeError where import Data.Foldable (toList) import Data.Maybe (isJust) import EasyTest -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Result (pattern Result) import qualified Unison.Result as Result import Unison.Symbol (Symbol) diff --git a/parser-typechecker/tests/Unison/Test/Ucm.hs b/parser-typechecker/tests/Unison/Test/Ucm.hs index 01349f6588..9bf002600a 100644 --- a/parser-typechecker/tests/Unison/Test/Ucm.hs +++ b/parser-typechecker/tests/Unison/Test/Ucm.hs @@ -22,7 +22,6 @@ import qualified System.IO.Temp as Temp import U.Util.String (stripMargin) import Unison.Codebase (CodebasePath) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Conversion.Upgrade12 as Upgrade12 import qualified Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Init as Codebase.Init import qualified Unison.Codebase.SqliteCodebase as SC @@ -30,10 +29,10 @@ import qualified Unison.Codebase.TranscriptParser as TR import Unison.Prelude (traceM) import qualified Unison.PrettyTerminal as PT import qualified Unison.Util.Pretty as P -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Symbol (Symbol) -data CodebaseFormat = CodebaseFormat1 | CodebaseFormat2 deriving (Show, Enum, Bounded) +data CodebaseFormat = CodebaseFormat2 deriving (Show, Enum, Bounded) data Codebase = Codebase CodebasePath CodebaseFormat deriving (Show) @@ -50,7 +49,7 @@ debugTranscriptOutput = False initCodebase :: CodebaseFormat -> IO Codebase initCodebase fmt = do - let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + let cbInit = case fmt of CodebaseFormat2 -> SC.init tmp <- Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test" @@ -63,11 +62,7 @@ deleteCodebase :: Codebase -> IO () deleteCodebase (Codebase path _) = removeDirectoryRecursive path upgradeCodebase :: Codebase -> IO Codebase -upgradeCodebase = \case - c@(Codebase _ CodebaseFormat2) -> fail $ show c ++ " already in V2 format." - Codebase path CodebaseFormat1 -> do - Upgrade12.upgradeCodebase path - pure $ Codebase path CodebaseFormat2 +upgradeCodebase = undefined runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do @@ -78,7 +73,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do >>= flip Temp.createTempDirectory ("ucm-test") pure $ tmpDir ".unisonConfig" let err err = fail $ "Parse error: \n" <> show err - cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + cbInit = case fmt of CodebaseFormat2 -> SC.init (closeCodebase, codebase) <- Codebase.Init.openCodebase cbInit "transcript" codebasePath >>= \case Left e -> fail $ P.toANSI 80 e @@ -99,7 +94,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a lowLevel (Codebase root fmt) f = do - let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init + let cbInit = case fmt of CodebaseFormat2 -> SC.init Codebase.Init.openCodebase cbInit "lowLevel" root >>= \case Left p -> PT.putPrettyLn p *> pure (error "This really should have loaded") Right (close, cb) -> f cb <* close diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 5a3d795153..7deb3197cc 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -20,11 +20,12 @@ import qualified Unison.ABT as ABT import qualified Unison.Builtin as Builtin import Unison.Codebase.Runtime ( Runtime, evaluateWatches ) import Unison.Codebase.Serialization ( getFromBytes, putBytes ) -import qualified Unison.Codebase.Serialization.V1 as V1 import Unison.DataDeclaration (EffectDeclaration, DataDeclaration) import Unison.Parser as Parser +import Unison.Parser.Ann (Ann) import qualified Unison.Parsers as Parsers import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.PrintError as PrintError import Unison.Reference ( Reference ) import Unison.Result (pattern Result, Result) @@ -42,7 +43,7 @@ import qualified Unison.Var as Var import qualified Unison.Test.Common as Common import qualified Unison.Names3 -type Note = Result.Note Symbol Parser.Ann +type Note = Result.Note Symbol Ann type TFile = UF.TypecheckedUnisonFile Symbol Ann type SynthResult = @@ -118,7 +119,7 @@ makePassingTest :: Runtime Symbol -> (EitherResult -> Test TFile) -> FilePath -> Test () makePassingTest rt how filepath = scope (shortName filepath) $ do uf <- typecheckingTest how filepath - resultTest rt uf filepath *> serializationTest uf + resultTest rt uf filepath shortName :: FilePath -> FilePath shortName = joinPath . drop 1 . splitPath @@ -156,42 +157,3 @@ resultTest rt uf filepath = do Left e -> crash $ show e else pure () -serializationTest :: TFile -> Test () -serializationTest uf = scope "serialization" . tests . concat $ - [ map testDataDeclaration (Map.toList $ UF.dataDeclarations' uf) - , map testEffectDeclaration (Map.toList $ UF.effectDeclarations' uf) - , map testTerm (Map.toList $ UF.hashTerms uf) - ] - where - putUnit :: Monad m => () -> m () - putUnit () = pure () - getUnit :: Monad m => m () - getUnit = pure () - testDataDeclaration :: (Symbol, (Reference, DataDeclaration Symbol Ann)) -> Test () - testDataDeclaration (name, (_, decl)) = scope (Var.nameStr name) $ - let decl' :: DataDeclaration Symbol () - decl' = void decl - bytes = putBytes (V1.putDataDeclaration V1.putSymbol putUnit) decl' - decl'' = getFromBytes (V1.getDataDeclaration V1.getSymbol getUnit) bytes - in expectEqual decl'' (Just decl') - testEffectDeclaration :: (Symbol, (Reference, EffectDeclaration Symbol Ann)) -> Test () - testEffectDeclaration (name, (_, decl)) = scope (Var.nameStr name) $ - let decl' :: EffectDeclaration Symbol () - decl' = void decl - bytes = putBytes (V1.putEffectDeclaration V1.putSymbol putUnit) decl' - decl'' = getFromBytes (V1.getEffectDeclaration V1.getSymbol getUnit) bytes - in expectEqual decl'' (Just decl') - testTerm :: (Symbol, (Reference, Term Symbol Ann, Type Symbol Ann)) -> Test () - testTerm (name, (_, tm, tp)) = scope (Var.nameStr name) $ - let tm' :: Term Symbol () - tm' = Term.amap (const ()) tm - tp' :: Type Symbol () - tp' = ABT.amap (const ()) tp - tmBytes = putBytes (V1.putTerm V1.putSymbol putUnit) tm' - tpBytes = putBytes (V1.putType V1.putSymbol putUnit) tp' - tm'' = getFromBytes (V1.getTerm V1.getSymbol getUnit) tmBytes - tp'' = getFromBytes (V1.getType V1.getSymbol getUnit) tpBytes - in tests - [ scope "type" $ expectEqual tp'' (Just tp') - , scope "term" $ expectEqual tm'' (Just tm') - ] diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 34b1c1881e..71e6b4bbc4 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -28,13 +28,16 @@ library Unison.Builtin.Terms Unison.Codebase Unison.Codebase.Branch + Unison.Codebase.Branch.Merge + Unison.Codebase.Branch.Names Unison.Codebase.BranchDiff Unison.Codebase.BranchUtil + Unison.Codebase.BuiltinAnnotation Unison.Codebase.Causal - Unison.Codebase.Classes + Unison.Codebase.Causal.FoldHistory Unison.Codebase.CodeLookup + Unison.Codebase.CodeLookup.Util Unison.Codebase.Conversion.Sync12 - Unison.Codebase.Conversion.Upgrade12 Unison.Codebase.Editor.AuthorInfo Unison.Codebase.Editor.Command Unison.Codebase.Editor.DisplayObject @@ -54,31 +57,51 @@ library Unison.Codebase.Editor.VersionParser Unison.Codebase.Execute Unison.Codebase.FileCodebase + Unison.Codebase.FileCodebase.Branch Unison.Codebase.FileCodebase.Branch.Dependencies + Unison.Codebase.FileCodebase.Codebase Unison.Codebase.FileCodebase.Common + Unison.Codebase.FileCodebase.DataDeclaration + Unison.Codebase.FileCodebase.Init + Unison.Codebase.FileCodebase.LabeledDependency + Unison.Codebase.FileCodebase.Metadata + Unison.Codebase.FileCodebase.Patch + Unison.Codebase.FileCodebase.Pattern + Unison.Codebase.FileCodebase.Reference + Unison.Codebase.FileCodebase.Reference.Util + Unison.Codebase.FileCodebase.Referent + Unison.Codebase.FileCodebase.Serialization.V1 Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex + Unison.Codebase.FileCodebase.Term + Unison.Codebase.FileCodebase.TermEdit + Unison.Codebase.FileCodebase.Type + Unison.Codebase.FileCodebase.TypeEdit Unison.Codebase.GitError Unison.Codebase.Init + Unison.Codebase.Init.CreateCodebaseError + Unison.Codebase.Init.Type Unison.Codebase.MainTerm Unison.Codebase.Metadata - Unison.Codebase.NameEdit Unison.Codebase.Patch Unison.Codebase.Path + Unison.Codebase.Path.Parse Unison.Codebase.Reflog Unison.Codebase.Runtime Unison.Codebase.Serialization - Unison.Codebase.Serialization.PutT - Unison.Codebase.Serialization.V1 Unison.Codebase.ShortBranchHash Unison.Codebase.SqliteCodebase Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Conversions + Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.SyncMode Unison.Codebase.TermEdit + Unison.Codebase.TermEdit.Typing Unison.Codebase.TranscriptParser + Unison.Codebase.Type Unison.Codebase.TypeEdit Unison.Codebase.Watch + Unison.CodebasePath Unison.CommandLine Unison.CommandLine.DisplayValues Unison.CommandLine.InputPattern @@ -89,11 +112,17 @@ library Unison.FileParser Unison.FileParsers Unison.Lexer + Unison.Lexer.Pos Unison.NamePrinter Unison.Parser + Unison.Parser.Ann Unison.Parsers - Unison.Path Unison.PrettyPrintEnv + Unison.PrettyPrintEnv.FQN + Unison.PrettyPrintEnv.Names + Unison.PrettyPrintEnv.Util + Unison.PrettyPrintEnvDecl + Unison.PrettyPrintEnvDecl.Names Unison.PrettyTerminal Unison.PrintError Unison.Result @@ -137,9 +166,14 @@ library Unison.TypeParser Unison.TypePrinter Unison.UnisonFile + Unison.UnisonFile.Env + Unison.UnisonFile.Error + Unison.UnisonFile.Names + Unison.UnisonFile.Type Unison.Util.AnnotatedText Unison.Util.Bytes Unison.Util.ColorText + Unison.Util.Convert Unison.Util.CycleTable Unison.Util.CyclicEq Unison.Util.CyclicOrd @@ -150,7 +184,6 @@ library Unison.Util.Less Unison.Util.Logger Unison.Util.Map - Unison.Util.Menu Unison.Util.PinBoard Unison.Util.Pretty Unison.Util.Range @@ -222,6 +255,7 @@ library , openapi3 , optparse-applicative , pem + , prelude-extras , primitive , process , random >=1.2.0 @@ -299,14 +333,10 @@ executable tests Unison.Core.Test.Name Unison.Test.ABT Unison.Test.ANF - Unison.Test.BaseUpgradePushPullTest Unison.Test.Cache Unison.Test.ClearCache - Unison.Test.Codebase Unison.Test.Codebase.Causal - Unison.Test.Codebase.FileCodebase Unison.Test.Codebase.Path - Unison.Test.Codebase.Upgrade12 Unison.Test.ColorText Unison.Test.Common Unison.Test.DataDeclaration diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index cc4427c2ed..361b37feed 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -43,7 +43,7 @@ import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR import Unison.CommandLine (plural', watchConfig) import qualified Unison.CommandLine.Main as CommandLine -import Unison.Parser (Ann) +import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Codebase.Runtime as Rt import qualified Unison.PrettyTerminal as PT @@ -52,7 +52,6 @@ import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import qualified Version -import qualified Unison.Codebase.Conversion.Upgrade12 as Upgrade12 usage :: String -> P.Pretty P.ColorText usage executableStr = P.callout "🌻" $ P.lines [ @@ -144,7 +143,7 @@ installSignalHandlers = do data CodebaseFormat = V1 | V2 deriving (Eq) cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann -cbInitFor = \case V1 -> FC.init; V2 -> SC.init +cbInitFor = \case V2 -> SC.init main :: IO () main = do @@ -164,7 +163,7 @@ main = do "--new-codebase" : rest -> (Just V2, rest) "--old-codebase" : rest -> (Just V1, rest) _ -> (Nothing, restargs0) - cbInit = case cbFormat of V1 -> FC.init; V2 -> SC.init + cbInit = case cbFormat of V2 -> SC.init currentDir <- getCurrentDirectory configFilePath <- getConfigFilePath mcodepath config <- @@ -243,12 +242,12 @@ upgradeCodebase mcodepath = "I'm upgrading the codebase in " <> P.backticked' (P.string root) "," <> "but it will" <> "take a while, and may even run out of memory. If you have" <> "trouble, contact us on #alphatesting and we'll try to help." - Upgrade12.upgradeCodebase root + undefined root PT.putPrettyLn . P.wrap $ P.newline <> "Try it out and once you're satisfied, you can safely(?) delete the old version from" <> P.newline - <> P.indentN 2 (P.string $ Codebase.codebasePath (FC.init @IO) root) + <> P.indentN 2 (P.string $ Codebase.codebasePath undefined root) <> P.newline <> "but there's no rush. You can access the old codebase again by passing the" <> P.backticked "--old-codebase" <> "flag at startup." diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 6548ac3add..8c0ab889c6 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -6,7 +6,35 @@ {-# Language PatternSynonyms #-} {-# Language ViewPatterns #-} -module Unison.DataDeclaration where +module Unison.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + DeclOrBuiltin(..), + Modifier(..), + allVars, + asDataDecl, + bindReferences, + constructorNames, + constructors, + constructorType, + constructorTypes, + constructorVars, + declConstructorReferents, + declDependencies, + declFields, + dependencies, + generateRecordAccessors, + hashDecls, + unhashComponent, + mkDataDecl', + mkEffectDecl', + typeOfConstructor, + withEffectDeclM, + amap, + updateDependencies, + ) +where import Unison.Prelude @@ -24,6 +52,7 @@ import qualified Unison.ABT as ABT import Unison.Hashable ( Accumulate , Hashable1 ) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import qualified Unison.Hashable as Hashable import qualified Unison.Name as Name import Unison.Reference ( Reference ) @@ -32,17 +61,17 @@ import qualified Unison.Reference.Util as Reference.Util import qualified Unison.Referent as Referent import qualified Unison.Term as Term import Unison.Term ( Term ) +import qualified Unison.Referent' as Referent' import Unison.Type ( Type ) import qualified Unison.Type as Type +import qualified Unison.Type.Names as Type import Unison.Var ( Var ) import qualified Unison.Var as Var -import Unison.Names3 (Names0) -import qualified Unison.Names3 as Names +import qualified Unison.Var.RefNamed as Var +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Pattern as Pattern import qualified Unison.ConstructorType as CT -type ConstructorId = Term.ConstructorId - type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) data DeclOrBuiltin v a = @@ -179,6 +208,7 @@ effectConstructorTerms rid ed = constructorTypes :: DataDeclaration v a -> [Type v a] constructorTypes = (snd <$>) . constructors +-- what is declFields? —AI declFields :: Var v => Decl v a -> Either [Int] [Int] declFields = bimap cf cf . first toDataDecl where @@ -199,12 +229,15 @@ constructorVars dd = fst <$> constructors dd constructorNames :: Var v => DataDeclaration v a -> [Text] constructorNames dd = Var.name <$> constructorVars dd +-- This function is unsound, since the `rid` and the `decl` have to match. +-- It should probably be hashed directly from the Decl, once we have a +-- reliable way of doing that. —AI declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] declConstructorReferents rid decl = - [ Referent.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] + [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] where ct = constructorType decl -constructorIds :: DataDeclaration v a -> [Int] +constructorIds :: DataDeclaration v a -> [ConstructorId] constructorIds dd = [0 .. length (constructors dd) - 1] -- | All variables mentioned in the given data declaration. @@ -218,14 +251,14 @@ allVars (DataDeclaration _ _ bound ctors) = Set.unions $ allVars' :: Ord v => Decl v a -> Set v allVars' = allVars . either toDataDecl id -bindNames :: Var v +bindReferences :: Var v => Set v - -> Names0 + -> Map Name.Name Reference -> DataDeclaration v a -> Names.ResolutionResult v a (DataDeclaration v a) -bindNames keepFree names (DataDeclaration m a bound constructors) = do +bindReferences keepFree names (DataDeclaration m a bound constructors) = do constructors <- for constructors $ \(a, v, ty) -> - (a,v,) <$> Type.bindNames keepFree names ty + (a,v,) <$> Type.bindReferences keepFree names ty pure $ DataDeclaration m a bound constructors dependencies :: Ord v => DataDeclaration v a -> Set Reference @@ -235,29 +268,6 @@ dependencies dd = third :: (a -> b) -> (x,y,a) -> (x,y,b) third f (x,y,a) = (x, y, f a) --- implementation of dataDeclToNames and effectDeclToNames -toNames0 :: Var v => CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names0 -toNames0 ct typeSymbol (Reference.DerivedId -> r) dd = - -- constructor names - foldMap names (constructorVars dd `zip` [0 ..]) - -- name of the type itself - <> Names.names0 mempty (Rel.singleton (Name.fromVar typeSymbol) r) - where - names (ctor, i) = - Names.names0 (Rel.singleton (Name.fromVar ctor) (Referent.Con r i ct)) mempty - -dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names0 -dataDeclToNames = toNames0 CT.Data - -effectDeclToNames :: Var v => v -> Reference.Id -> EffectDeclaration v a -> Names0 -effectDeclToNames typeSymbol r ed = toNames0 CT.Effect typeSymbol r $ toDataDecl ed - -dataDeclToNames' :: Var v => (v, (Reference.Id, DataDeclaration v a)) -> Names0 -dataDeclToNames' (v,(r,d)) = dataDeclToNames v r d - -effectDeclToNames' :: Var v => (v, (Reference.Id, EffectDeclaration v a)) -> Names0 -effectDeclToNames' (v, (r, d)) = effectDeclToNames v r d - mkEffectDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> EffectDeclaration v a mkEffectDecl' m a b cs = EffectDeclaration (DataDeclaration m a b cs) @@ -404,12 +414,11 @@ hashDecls decls = do varToRef' = second Reference.DerivedId <$> varToRef decls' = bindTypes <$> decls bindTypes dd = dd { constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd } - typeNames0 = Names.names0 mempty - $ Rel.fromList (first Name.fromVar <$> varToRef') + typeReferences = Map.fromList (first Name.fromVar <$> varToRef') -- normalize the order of the constructors based on a hash of their types sortCtors dd = dd { constructors' = sortOn hash3 $ constructors' dd } hash3 (_, _, typ) = ABT.hash typ :: Hash - decls' <- fmap sortCtors <$> traverse (bindNames mempty typeNames0) decls' + decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' pure [ (v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls'] ] amap :: (a -> a2) -> Decl v a -> Decl v a2 diff --git a/unison-core/src/Unison/DataDeclaration/ConstructorId.hs b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs new file mode 100644 index 0000000000..d04f59f280 --- /dev/null +++ b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.DataDeclaration.ConstructorId (ConstructorId) where + +type ConstructorId = Int \ No newline at end of file diff --git a/unison-core/src/Unison/DataDeclaration/Names.hs b/unison-core/src/Unison/DataDeclaration/Names.hs new file mode 100644 index 0000000000..64bf046da9 --- /dev/null +++ b/unison-core/src/Unison/DataDeclaration/Names.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.DataDeclaration.Names (bindNames, dataDeclToNames', effectDeclToNames') where + +import Unison.Prelude + +import Unison.DataDeclaration (DataDeclaration (DataDeclaration), EffectDeclaration) +import qualified Unison.DataDeclaration as DD + + +import qualified Unison.Util.Relation as Rel +import Prelude hiding ( cycle ) +import qualified Unison.Name as Name +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import qualified Unison.Type.Names as Type.Names +import Unison.Var ( Var ) +import Unison.Names3 (Names0) +import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.ConstructorType as CT + +-- implementation of dataDeclToNames and effectDeclToNames +toNames0 :: Var v => CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names0 +toNames0 ct typeSymbol (Reference.DerivedId -> r) dd = + -- constructor names + foldMap names (DD.constructorVars dd `zip` [0 ..]) + -- name of the type itself + <> Names.names0 mempty (Rel.singleton (Name.fromVar typeSymbol) r) + where + names (ctor, i) = + Names.names0 (Rel.singleton (Name.fromVar ctor) (Referent.Con r i ct)) mempty + +dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names0 +dataDeclToNames = toNames0 CT.Data + +effectDeclToNames :: Var v => v -> Reference.Id -> EffectDeclaration v a -> Names0 +effectDeclToNames typeSymbol r ed = toNames0 CT.Effect typeSymbol r $ DD.toDataDecl ed + +dataDeclToNames' :: Var v => (v, (Reference.Id, DataDeclaration v a)) -> Names0 +dataDeclToNames' (v, (r,d)) = dataDeclToNames v r d + +effectDeclToNames' :: Var v => (v, (Reference.Id, EffectDeclaration v a)) -> Names0 +effectDeclToNames' (v, (r, d)) = effectDeclToNames v r d + +bindNames :: Var v + => Set v + -> Names0 + -> DataDeclaration v a + -> Names.ResolutionResult v a (DataDeclaration v a) +bindNames keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.Names.bindNames keepFree names ty + pure $ DataDeclaration m a bound constructors + diff --git a/unison-core/src/Unison/HashQualified'.hs b/unison-core/src/Unison/HashQualified'.hs index be1ae16986..fa8380f605 100644 --- a/unison-core/src/Unison/HashQualified'.hs +++ b/unison-core/src/Unison/HashQualified'.hs @@ -113,10 +113,14 @@ requalify hq r = case hq of NameOnly n -> fromNamedReferent n r HashQualified n _ -> fromNamedReferent n r -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 +-- `HashQualified` is usually used for display, so we sort it alphabetically +instance Name.Alphabetical n => Ord (HashQualified n) where + compare (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2 + -- NameOnly comes first + compare NameOnly{} HashQualified{} = LT + compare HashQualified{} NameOnly{} = GT + compare (HashQualified n sh) (HashQualified n2 sh2) = + Name.compareAlphabetical n n2 <> compare sh sh2 instance IsString (HashQualified Name) where fromString = unsafeFromText . Text.pack diff --git a/unison-core/src/Unison/HashQualified.hs b/unison-core/src/Unison/HashQualified.hs index ff8ecef7f7..09e0d5cc59 100644 --- a/unison-core/src/Unison/HashQualified.hs +++ b/unison-core/src/Unison/HashQualified.hs @@ -11,7 +11,7 @@ import Unison.Name ( Name, Convert, Parse ) import qualified Unison.Name as Name import Unison.Reference ( Reference ) import qualified Unison.Reference as Reference -import Unison.Referent ( Referent ) +import Unison.Referent ( Referent, ConstructorId ) import qualified Unison.Referent as Referent import Unison.ShortHash ( ShortHash ) import qualified Unison.ShortHash as SH @@ -122,7 +122,7 @@ fromReferent = HashOnly . Referent.toShortHash fromReference :: Reference -> HashQualified Name fromReference = HashOnly . Reference.toShortHash -fromPattern :: Reference -> Int -> HashQualified Name +fromPattern :: Reference -> ConstructorId -> HashQualified Name fromPattern r cid = HashOnly $ Referent.patternShortHash r cid fromName :: n -> HashQualified n @@ -157,16 +157,26 @@ requalify hq r = case hq of HashQualified n _ -> fromNamedReferent n r HashOnly _ -> fromReferent r --- 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 - compare a b = case compare (toName a) (toName b) of - EQ -> compare (toHash a) (toHash b) - o -> o +-- Ordered alphabetically, based on the name. Hashes come last. +instance (Eq n, Name.Alphabetical n) => Ord (HashQualified n) where + compare a b = case (toName a, toName b) of + (Just n , Just n2) -> Name.compareAlphabetical n n2 + (Nothing, Just _) -> GT + (Just _ , Nothing) -> LT + (Nothing, Nothing) -> EQ + <> + case (toHash a, toHash b) of + (Nothing, Nothing) -> EQ + (Nothing, Just _) -> LT -- prefer NameOnly to HashQualified + (Just _, Nothing) -> GT + (Just sh, Just sh2) -> compare sh sh2 instance Convert n n2 => Convert (HashQualified n) (HashQualified n2) where convert = fmap Name.convert +instance Convert n (HashQualified n) where + convert = NameOnly + instance Parse Text (HashQualified Name) where parse = fromText diff --git a/unison-core/src/Unison/LabeledDependency.hs b/unison-core/src/Unison/LabeledDependency.hs index 13f5a858a1..289d283fa8 100644 --- a/unison-core/src/Unison/LabeledDependency.hs +++ b/unison-core/src/Unison/LabeledDependency.hs @@ -19,7 +19,7 @@ import Unison.Prelude hiding (fold) import Unison.ConstructorType (ConstructorType(Data, Effect)) import Unison.Reference (Reference(DerivedId), Id) -import Unison.Referent (Referent, pattern Ref, pattern Con, Referent'(Ref', Con')) +import Unison.Referent (Referent, pattern Ref, pattern Con, ConstructorId) import qualified Data.Set as Set -- dumb constructor name is private @@ -28,8 +28,8 @@ newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Sho derivedType, derivedTerm :: Id -> LabeledDependency typeRef, termRef :: Reference -> LabeledDependency referent :: Referent -> LabeledDependency -dataConstructor :: Reference -> Int -> LabeledDependency -effectConstructor :: Reference -> Int -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency derivedType = X . Left . DerivedId derivedTerm = X . Right . Ref . DerivedId @@ -52,5 +52,5 @@ partition = partitionEithers . map (\(X e) -> e) . toList toReference :: LabeledDependency -> Either Reference Reference toReference = \case X (Left r) -> Left r - X (Right (Ref' r)) -> Right r - X (Right (Con' r _ _)) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 93e7acb2e4..b2e5a0de1d 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -13,17 +13,25 @@ module Unison.Name , isPrefixOf , joinDot , makeAbsolute + , isAbsolute , parent + , module Unison.Util.Alphabetical , sortNames , sortNamed + , sortNameds , sortByText , sortNamed' , stripNamePrefix , stripPrefixes , segments + , reverseSegments , countSegments + , compareSuffix , segments' , suffixes + , searchBySuffix + , suffixFrom + , shortestUniqueSuffix , toString , toText , toVar @@ -45,14 +53,17 @@ import Unison.NameSegment ( NameSegment(NameSegment) import Control.Lens ( unsnoc ) import qualified Control.Lens as Lens import qualified Data.Text as Text +import qualified Data.Set as Set import qualified Unison.Hashable as H +import Unison.Util.Alphabetical (Alphabetical,compareAlphabetical) +import qualified Unison.Util.Relation as R import Unison.Var ( Var ) import qualified Unison.Var as Var import qualified Data.RFC5051 as RFC5051 -import Data.List ( sortBy, tails ) +import Data.List ( sortBy, tails, inits, find ) newtype Name = Name { toText :: Text } - deriving (Eq, Ord, Monoid, Semigroup, Generic) + deriving (Eq, Monoid, Semigroup, Generic) sortNames :: [Name] -> [Name] sortNames = sortNamed id @@ -60,6 +71,9 @@ sortNames = sortNamed id sortNamed :: (a -> Name) -> [a] -> [a] sortNamed by = sortByText (toText . by) +sortNameds :: (a -> [Name]) -> [a] -> [a] +sortNameds by = sortByText (Text.intercalate "." . map toText . by) + sortByText :: (a -> Text) -> [a] -> [a] sortByText by as = let as' = [ (a, by a) | a <- as ] @@ -120,6 +134,18 @@ stripNamePrefix prefix name = where mid = if toText prefix == "." then "" else "." +-- suffixFrom Int builtin.Int.+ ==> Int.+ +-- suffixFrom Int Int.negate ==> Int.negate +-- +-- Currently used as an implementation detail of expanding wildcard +-- imports, (like `use Int` should catch `builtin.Int.+`) +-- but it may be generally useful elsewhere. See `expandWildcardImports` +-- for details. +suffixFrom :: Name -> Name -> Maybe Name +suffixFrom mid overall = case Text.breakOnAll (toText mid) (toText overall) of + [] -> Nothing + (_, rem):_ -> Just (Name rem) + -- a.b.c.d -> d stripPrefixes :: Name -> Name stripPrefixes = maybe "" fromSegment . lastMay . segments @@ -178,9 +204,73 @@ fromSegment = unsafeFromText . NameSegment.toText segments :: Name -> [NameSegment] segments (Name n) = NameSegment <$> segments' n +reverseSegments :: Name -> [NameSegment] +reverseSegments (Name n) = NameSegment <$> NameSegment.reverseSegments' n + countSegments :: Name -> Int countSegments n = length (segments n) +-- The `Ord` instance for `Name` considers the segments of the name +-- starting from the last, enabling efficient search by name suffix. +-- +-- To order names alphabetically for purposes of display to a human, +-- `sortNamed` or one of its variants should be used, which provides a +-- Unicode and capitalization aware sorting (based on RFC5051). +instance Ord Name where + compare n1 n2 = + (reverseSegments n1 `compare` reverseSegments n2) + <> (isAbsolute n1 `compare` isAbsolute n2) + +instance Alphabetical Name where + compareAlphabetical (Name n1) (Name n2) = compareAlphabetical n1 n2 + +isAbsolute :: Name -> Bool +isAbsolute (Name n) = Text.isPrefixOf "." n + +-- If there's no exact matches for `suffix` in `rel`, find all +-- `r` in `rel` whose corresponding name `suffix` as a suffix. +-- For example, `searchBySuffix List.map {(base.List.map, r1)}` +-- will return `{r1}`. +-- +-- NB: Implementation uses logarithmic time lookups, not a linear scan. +searchBySuffix :: (Ord r) => Name -> R.Relation Name r -> Set r +searchBySuffix suffix rel = + R.lookupDom suffix rel `orElse` R.searchDom (compareSuffix suffix) rel + where + orElse s1 s2 = if Set.null s1 then s2 else s1 + +-- `compareSuffix suffix n` is equal to `compare n' suffix`, where +-- n' is `n` with only the last `countSegments suffix` segments. +-- +-- Used for suffix-based lookup of a name. For instance, given a `r : Relation Name x`, +-- `Relation.searchDom (compareSuffix "foo.bar") r` will find all `r` whose name +-- has `foo.bar` as a suffix. +compareSuffix :: Name -> Name -> Ordering +compareSuffix suffix = + let + suffixSegs = reverseSegments suffix + len = length suffixSegs + in + \n -> take len (reverseSegments n) `compare` suffixSegs + +-- Tries to shorten `fqn` to the smallest suffix that still refers +-- to to `r`. Uses an efficient logarithmic lookup in the provided relation. +-- The returned `Name` may refer to multiple hashes if the original FQN +-- did as well. +-- +-- NB: Only works if the `Ord` instance for `Name` orders based on +-- `Name.reverseSegments`. +shortestUniqueSuffix :: Ord r => Name -> r -> R.Relation Name r -> Name +shortestUniqueSuffix fqn r rel = + maybe fqn (convert . reverse) (find isOk suffixes) + where + allowed = R.lookupDom fqn rel + suffixes = drop 1 (inits (reverseSegments fqn)) + isOk suffix = (Set.size rs == 1 && Set.findMin rs == r) || rs == allowed + where rs = R.searchDom compareEnd rel + compareEnd n = compare (take len (reverseSegments n)) suffix + len = length suffix + class Convert a b where convert :: a -> b @@ -190,6 +280,8 @@ class Parse a b where instance Convert Name Text where convert = toText instance Convert Name [NameSegment] where convert = segments instance Convert NameSegment Name where convert = fromSegment +instance Convert [NameSegment] Name where + convert sgs = unsafeFromText (Text.intercalate "." (map NameSegment.toText sgs)) instance Parse Text NameSegment where parse txt = case NameSegment.segments' txt of diff --git a/unison-core/src/Unison/NameSegment.hs b/unison-core/src/Unison/NameSegment.hs index d220ebfabc..6204dd557d 100644 --- a/unison-core/src/Unison/NameSegment.hs +++ b/unison-core/src/Unison/NameSegment.hs @@ -6,10 +6,14 @@ import Unison.Prelude import qualified Data.Text as Text import qualified Unison.Hashable as H +import Unison.Util.Alphabetical (Alphabetical(compareAlphabetical)) -- Represents the parts of a name between the `.`s newtype NameSegment = NameSegment { toText :: Text } deriving (Eq, Ord) +instance Alphabetical NameSegment where + compareAlphabetical n1 n2 = compareAlphabetical (toText n1) (toText n2) + -- Split text into segments. A smarter version of `Text.splitOn` that handles -- the name `.` properly. segments' :: Text -> [Text] @@ -21,6 +25,25 @@ segments' n = go split go ("" : z) = go z go (x : y) = x : go y +-- Same as reverse . segments', but produces the output as a +-- lazy list, suitable for suffix-based ordering purposes or +-- building suffix tries. Examples: +-- +-- reverseSegments' "foo.bar.baz" => ["baz","bar","foo"] +-- reverseSegments' ".foo.bar.baz" => ["baz","bar","foo"] +-- reverseSegments' ".." => ["."] +-- reverseSegments' "Nat.++" => ["++","Nat"] +-- reverseSegments' "Nat.++.zoo" => ["zoo","++","Nat"] +reverseSegments' :: Text -> [Text] +reverseSegments' = go + where + go "" = [] + go t = let + seg0 = Text.takeWhileEnd (/= '.') t + seg = if Text.null seg0 then Text.takeEnd 1 t else seg0 + rem = Text.dropEnd (Text.length seg + 1) t + in seg : go rem + instance H.Hashable NameSegment where tokens s = [H.Text (toText s)] diff --git a/unison-core/src/Unison/Names/ResolutionResult.hs b/unison-core/src/Unison/Names/ResolutionResult.hs new file mode 100644 index 0000000000..9968a26463 --- /dev/null +++ b/unison-core/src/Unison/Names/ResolutionResult.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Names.ResolutionResult where + +import Unison.Prelude +import Unison.Reference as Reference ( Reference ) +import Unison.Referent as Referent ( Referent ) + +data ResolutionFailure v a + = TermResolutionFailure v a (Set Referent) + | TypeResolutionFailure v a (Set Reference) + deriving (Eq,Ord,Show) + +type ResolutionResult v a r = Either (Seq (ResolutionFailure v a)) r diff --git a/unison-core/src/Unison/Names2.hs b/unison-core/src/Unison/Names2.hs index cedb55c69c..835627ab2e 100644 --- a/unison-core/src/Unison/Names2.hs +++ b/unison-core/src/Unison/Names2.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Unison.Names2 ( Names0 @@ -49,10 +50,12 @@ import Unison.Prelude import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text as Text import Prelude hiding (filter) +import qualified Prelude import Unison.HashQualified' (HashQualified) import qualified Unison.HashQualified' as HQ -import Unison.Name (Name) +import Unison.Name (Name,Alphabetical) import qualified Unison.Name as Name import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -85,11 +88,25 @@ fuzzyFind fuzzyFind query names = fmap flatten . fuzzyFinds (Name.toString . fst) query + . Prelude.filter prefilter . Map.toList -- `mapMonotonic` is safe here and saves a log n factor $ (Set.mapMonotonic Left <$> R.toMultimap (terms names)) <> (Set.mapMonotonic Right <$> R.toMultimap (types names)) where + lowerqueryt = Text.toLower . Text.pack <$> query + -- For performance, case-insensitive substring matching as a pre-filter + -- This finds fewer matches than subsequence matching, but is + -- (currently) way faster even on large name sets. + prefilter (Name.toText -> name, _) = case lowerqueryt of + -- Special cases here just to help optimizer, since + -- not sure if `all` will get sufficiently unrolled for + -- Text fusion to work out. + [q] -> q `Text.isInfixOf` lowername + [q1,q2] -> q1 `Text.isInfixOf` lowername && q2 `Text.isInfixOf` lowername + query -> all (`Text.isInfixOf` lowername) query + where + lowername = Text.toLower name flatten (a, (b, c)) = (a, b, c) fuzzyFinds :: (a -> String) -> [String] -> [a] -> [(FZF.Alignment, a)] fuzzyFinds f query d = @@ -248,7 +265,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, Alphabetical 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 @@ -257,31 +274,31 @@ 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, Alphabetical 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, Alphabetical 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, Alphabetical 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, Alphabetical 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, Alphabetical 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, Alphabetical 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 diff --git a/unison-core/src/Unison/Names3.hs b/unison-core/src/Unison/Names3.hs index 987496a4a9..82f264483c 100644 --- a/unison-core/src/Unison/Names3.hs +++ b/unison-core/src/Unison/Names3.hs @@ -6,7 +6,8 @@ module Unison.Names3 where import Unison.Prelude -import Data.List.Extra (nubOrd) +import Control.Lens (view, _4) +import Data.List.Extra (nubOrd, sort) import Unison.HashQualified (HashQualified) import qualified Unison.HashQualified as HQ import qualified Unison.HashQualified' as HQ' @@ -26,15 +27,9 @@ import qualified Unison.ConstructorType as CT data Names = Names { currentNames :: Names0, oldNames :: Names0 } deriving Show type Names0 = Unison.Names2.Names0 +pattern Names0 :: Relation n Referent -> Relation n Reference -> Names.Names' n pattern Names0 terms types = Unison.Names2.Names terms types -data ResolutionFailure v a - = TermResolutionFailure v a (Set Referent) - | TypeResolutionFailure v a (Set Reference) - deriving (Eq,Ord,Show) - -type ResolutionResult v a r = Either (Seq (ResolutionFailure v a)) r - -- For all names in `ns`, (ex: foo.bar.baz), generate the list of suffixes -- of that name [[foo.bar.baz], [bar.baz], [baz]]. Insert these suffixes -- into a multimap map along with their corresponding refs. Any suffix @@ -192,6 +187,30 @@ termName length r Names{..} = where hq n = HQ'.take length (HQ'.fromNamedReferent n r) isConflicted n = R.manyDom n (Names.terms currentNames) +suffixedTypeName :: Int -> Reference -> Names -> [HQ.HashQualified Name] +suffixedTermName :: Int -> Referent -> Names -> [HQ.HashQualified Name] +(suffixedTermName,suffixedTypeName) = + ( suffixedName termName (Names.terms . currentNames) HQ'.fromNamedReferent + , suffixedName typeName (Names.types . currentNames) HQ'.fromNamedReference ) + where + suffixedName fallback getRel hq' length r ns@(getRel -> rel) = + if R.memberRan r rel + then go $ toList (R.lookupRan r rel) + else sort $ map Name.convert $ Set.toList (fallback length r ns) + where + -- Orders names, using these criteria, in this order: + -- 1. NameOnly comes before HashQualified, + -- 2. Shorter names (in terms of segment count) come before longer ones + -- 3. If same on attributes 1 and 2, compare alphabetically + go :: [Name] -> [HashQualified Name] + go fqns = map (view _4) . sort $ map f fqns where + f fqn = let + n' = Name.shortestUniqueSuffix fqn r rel + isHQ'd = R.manyDom fqn rel -- it is conflicted + hq n = HQ'.take length (hq' n r) + hqn = Name.convert $ if isHQ'd then hq n' else HQ'.fromName n' + in (isHQ'd, Name.countSegments fqn, Name.isAbsolute n', hqn) + -- Set HashQualified -> Branch m -> Action' m v Names -- Set HashQualified -> Branch m -> Free (Command m i v) Names -- Set HashQualified -> Branch m -> Command m i v Names diff --git a/unison-core/src/Unison/Pattern.hs b/unison-core/src/Unison/Pattern.hs index 7506a791c1..8dd8a67675 100644 --- a/unison-core/src/Unison/Pattern.hs +++ b/unison-core/src/Unison/Pattern.hs @@ -4,16 +4,15 @@ module Unison.Pattern where import Unison.Prelude +import qualified Data.Foldable as Foldable hiding (foldMap') import Data.List (intercalate) -import Data.Foldable as Foldable hiding (foldMap') -import Unison.Reference (Reference) -import qualified Unison.Hashable as H -import qualified Unison.Type as Type import qualified Data.Set as Set -import qualified Unison.LabeledDependency as LD +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import qualified Unison.Hashable as H import Unison.LabeledDependency (LabeledDependency) - -type ConstructorId = Int +import qualified Unison.LabeledDependency as LD +import Unison.Reference (Reference) +import qualified Unison.Type as Type data Pattern loc = Unbound loc @@ -24,10 +23,10 @@ data Pattern loc | Float loc !Double | Text loc !Text | Char loc !Char - | Constructor loc !Reference !Int [Pattern loc] + | Constructor loc !Reference !ConstructorId [Pattern loc] | As loc (Pattern loc) | EffectPure loc (Pattern loc) - | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | EffectBind loc !Reference !ConstructorId [Pattern loc] (Pattern loc) | SequenceLiteral loc [Pattern loc] | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) deriving (Ord,Generic,Functor,Foldable,Traversable) diff --git a/unison-core/src/Unison/PatternCompat.hs b/unison-core/src/Unison/PatternCompat.hs deleted file mode 100644 index 31ee1c532d..0000000000 --- a/unison-core/src/Unison/PatternCompat.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# Language PatternSynonyms #-} - -module Unison.PatternCompat where - -import qualified Unison.Pattern as P - -type Pattern = P.Pattern () - -{-# COMPLETE Unbound, Var, Boolean, Int, Nat, Float, Text, Char, Constructor, As, EffectPure, EffectBind, SequenceLiteral, SequenceOp #-} - -pattern Unbound = P.Unbound () -pattern Var = P.Var () -pattern Boolean b = P.Boolean () b -pattern Int n = P.Int () n -pattern Nat n = P.Nat () n -pattern Float n = P.Float () n -pattern Text t = P.Text () t -pattern Char c = P.Char () c -pattern Constructor r cid ps = P.Constructor () r cid ps -pattern As p = P.As () p -pattern EffectPure p = P.EffectPure () p -pattern EffectBind r cid ps k = P.EffectBind () r cid ps k -pattern SequenceLiteral ps = P.SequenceLiteral () ps -pattern SequenceOp ph op pt = P.SequenceOp () ph op pt - -{-# COMPLETE Snoc, Cons, Concat #-} -type SeqOp = P.SeqOp -pattern Snoc = P.Snoc -pattern Cons = P.Cons -pattern Concat = P.Concat diff --git a/unison-core/src/Unison/Reference/Util.hs b/unison-core/src/Unison/Reference/Util.hs index 2d63d2d6b1..b08f41c520 100644 --- a/unison-core/src/Unison/Reference/Util.hs +++ b/unison-core/src/Unison/Reference/Util.hs @@ -2,7 +2,6 @@ module Unison.Reference.Util where import Unison.Prelude -import Unison.Reference import qualified Unison.Reference as Reference import Unison.Hashable (Hashable1) import Unison.ABT (Var) @@ -16,7 +15,7 @@ hashComponents :: -> Map v (Reference.Id, ABT.Term f v a) hashComponents embedRef tms = Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] - where cs = components $ ABT.hashComponents ref tms - ref h i n = embedRef (Id h i n) + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) diff --git a/unison-core/src/Unison/Referent'.hs b/unison-core/src/Unison/Referent'.hs new file mode 100644 index 0000000000..0d2689956f --- /dev/null +++ b/unison-core/src/Unison/Referent'.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Referent' where + +import Unison.ConstructorType (ConstructorType) +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Hashable (Hashable (tokens)) +import qualified Unison.Hashable as H +import Unison.Prelude (Word64) + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. + +-- | When @Ref'@ then @r@ represents a term. +-- +-- When @Con'@ then @r@ is a type declaration. +data Referent' r = Ref' r | Con' r ConstructorId ConstructorType + deriving (Show, Ord, Eq, Functor) + +isConstructor :: Referent' r -> Bool +isConstructor Con' {} = True +isConstructor _ = False + +toTermReference :: Referent' r -> Maybe r +toTermReference = \case + Ref' r -> Just r + _ -> Nothing + +toReference' :: Referent' r -> r +toReference' = \case + Ref' r -> r + Con' r _i _t -> r + +toTypeReference :: Referent' r -> Maybe r +toTypeReference = \case + Con' r _i _t -> Just r + _ -> Nothing + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct + +instance Hashable r => Hashable (Referent' r) where + tokens (Ref' r) = [H.Tag 0] ++ H.tokens r + tokens (Con' r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt \ No newline at end of file diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index 77801af37d..62fde5d4ae 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -1,21 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -module Unison.Referent where - -import Unison.Prelude - -import qualified Data.Char as Char -import qualified Data.Text as Text -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H -import Unison.Reference (Reference) -import qualified Unison.Reference as R -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH - +module Unison.Referent + ( Referent, + pattern Ref, + pattern Con, + ConstructorId, + Id, + pattern RefId, + pattern ConId, + fold, + toReference, + fromText, + + -- * ShortHash helpers + isPrefixOf, + toShortHash, + toText, + patternShortHash, + ) +where + +import qualified Data.Char as Char +import qualified Data.Text as Text import Unison.ConstructorType (ConstructorType) import qualified Unison.ConstructorType as CT +import Unison.DataDeclaration.ConstructorId (ConstructorId) +import Unison.Prelude hiding (fold) +import Unison.Reference (Reference) +import qualified Unison.Reference as R +import Unison.Referent' (Referent' (..), toReference') +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH -- | Specifies a term. -- @@ -24,23 +40,25 @@ import qualified Unison.ConstructorType as CT -- Slightly odd naming. This is the "referent of term name in the codebase", -- rather than the target of a Reference. type Referent = Referent' Reference + pattern Ref :: Reference -> Referent pattern Ref r = Ref' r -pattern Con :: Reference -> Int -> ConstructorType -> Referent + +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent pattern Con r i t = Con' r i t + {-# COMPLETE Ref, Con #-} --- | Cannot be a builtin. +-- | By definition, cannot be a builtin. type Id = Referent' R.Id --- | When @Ref'@ then @r@ represents a term. --- --- When @Con'@ then @r@ is a type declaration. -data Referent' r = Ref' r | Con' r Int ConstructorType - deriving (Show, Ord, Eq, Functor) +pattern RefId :: R.Id -> Unison.Referent.Id +pattern RefId r = Ref' r + +pattern ConId :: R.Id -> ConstructorId -> ConstructorType -> Unison.Referent.Id +pattern ConId r i t = Con' r i t -type Pos = Word64 -type Size = Word64 +{-# COMPLETE RefId, ConId #-} -- referentToTerm moved to Term.fromReferent -- termToReferent moved to Term.toReferent @@ -88,11 +106,6 @@ toTermReference = \case toReference :: Referent -> Reference toReference = toReference' -toReference' :: Referent' r -> r -toReference' = \case - Ref' r -> r - Con' r _i _t -> r - fromId :: Id -> Referent fromId = fmap R.DerivedId @@ -135,7 +148,3 @@ fold :: (r -> a) -> (r -> Int -> ConstructorType -> a) -> Referent' r -> a fold fr fc = \case Ref' r -> fr r Con' r i ct -> fc r i ct - -instance Hashable Referent where - tokens (Ref r) = [H.Tag 0] ++ H.tokens r - tokens (Con r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 0e0df4dfec..d75828350d 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -28,12 +28,13 @@ import Unison.Hashable (Hashable1, accumulateToken) import qualified Unison.Hashable as Hashable import Unison.Names3 ( Names0 ) import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference, pattern Builtin) import qualified Unison.Reference as Reference import qualified Unison.Reference.Util as ReferenceUtil -import Unison.Referent (Referent) +import Unison.Referent (Referent, ConstructorId) import qualified Unison.Referent as Referent import Unison.Type (Type) import qualified Unison.Type as Type @@ -42,15 +43,13 @@ import qualified Unison.ConstructorType as CT import Unison.Util.List (multimap, validate) import Unison.Var (Var) import qualified Unison.Var as Var +import qualified Unison.Var.RefNamed as Var import Unsafe.Coerce import Unison.Symbol (Symbol) import qualified Unison.Name as Name import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) --- This gets reexported; should maybe live somewhere other than Pattern, though. -type ConstructorId = Pattern.ConstructorId - data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) @@ -115,27 +114,12 @@ type Term0 v = Term v () -- | Terms with type variables in `vt`, and term variables in `v` type Term0' vt v = Term' vt v () --- bindExternals --- :: forall v a b b2 --- . Var v --- => [(v, Term2 v b a v b2)] --- -> [(v, Reference)] --- -> Term2 v b a v a --- -> Term2 v b a v a --- bindBuiltins termBuiltins typeBuiltins = f . g --- where --- f :: Term2 v b a v a -> Term2 v b a v a --- f = typeMap (Type.bindBuiltins typeBuiltins) --- g :: Term2 v b a v a -> Term2 v b a v a --- g = ABT.substsInheritAnnotation termBuiltins bindNames :: forall v a . Var v => Set v -> Names0 -> Term v a -> Names.ResolutionResult v a (Term v a) --- bindNames keepFreeTerms _ _ | trace "Keep free terms:" False --- || traceShow keepFreeTerms False = undefined bindNames keepFreeTerms ns e = do let freeTmVars = [ (v,a) | (v,a) <- ABT.freeVarOccurrences keepFreeTerms e ] -- !_ = trace "free term vars: " () @@ -161,13 +145,6 @@ bindSomeNames => Names0 -> Term v a -> Names.ResolutionResult v a (Term v a) --- bindSomeNames ns e | trace "Term.bindSome" False --- || trace "Names =" False --- || traceShow ns False --- || trace "Free type vars:" False --- || traceShow (freeTypeVars e) False --- || traceShow e False --- = undefined bindSomeNames ns e = bindNames keepFree ns e where keepFree = Set.difference (freeVars e) (Set.map Name.toVar $ Rel.dom (Names.terms0 ns)) @@ -989,6 +966,7 @@ unhashComponent m = let go e = e in second unhash1 <$> m' + hashComponents :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) hashComponents = ReferenceUtil.hashComponents $ refId () diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index d7a972948d..35669b9f2e 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -26,8 +26,7 @@ import qualified Unison.Reference.Util as ReferenceUtil import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Settings as Settings -import qualified Unison.Util.Relation as R -import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name import qualified Unison.Util.List as List @@ -62,17 +61,17 @@ bindExternal :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] -bindNames +bindReferences :: Var v => Set v - -> Names.Names0 + -> Map Name.Name Reference -> Type v a -> Names.ResolutionResult v a (Type v a) -bindNames keepFree ns t = let +bindReferences keepFree ns t = let fvs = ABT.freeVarOccurrences keepFree t - rs = [(v, a, R.lookupDom (Name.fromVar v) (Names.types0 ns)) | (v,a) <- fvs ] - ok (v, a, rs) = if Set.size rs == 1 then pure (v, Set.findMin rs) - else Left (pure (Names.TypeResolutionFailure v a rs)) + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) in List.validate ok rs <&> \es -> bindExternal es t newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq @@ -186,9 +185,6 @@ isArrow _ = False -- some smart constructors ---vectorOf :: Ord v => a -> Type v a -> Type v ---vectorOf a t = vector `app` t - ref :: Ord v => a -> Reference -> Type v a ref a = ABT.tm' a . Ref @@ -204,9 +200,6 @@ typeLink a = ABT.tm' a . Ref $ typeLinkRef derivedBase32Hex :: Ord v => Reference -> a -> Type v a derivedBase32Hex r a = ref a r --- derivedBase58' :: Text -> Reference --- derivedBase58' base58 = Reference.derivedBase58 base58 0 1 - intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference intRef = Reference.Builtin "Int" natRef = Reference.Builtin "Nat" diff --git a/unison-core/src/Unison/Type/Names.hs b/unison-core/src/Unison/Type/Names.hs new file mode 100644 index 0000000000..e3bdc5ddf7 --- /dev/null +++ b/unison-core/src/Unison/Type/Names.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Type.Names where + +import Unison.Prelude + +import Unison.Type +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names3 as Names +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +bindNames + :: Var v + => Set v + -> Names.Names0 + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns0 t = let + ns = Names.Names ns0 mempty + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Names.lookupHQType (Name.convert $ Name.fromVar v) ns) | (v,a) <- fvs ] + ok (v, a, rs) = if Set.size rs == 1 then pure (v, Set.findMin rs) + else Left (pure (Names.TypeResolutionFailure v a rs)) + in List.validate ok rs <&> \es -> bindExternal es t \ No newline at end of file diff --git a/unison-core/src/Unison/Util/Alphabetical.hs b/unison-core/src/Unison/Util/Alphabetical.hs new file mode 100644 index 0000000000..df0fb19de4 --- /dev/null +++ b/unison-core/src/Unison/Util/Alphabetical.hs @@ -0,0 +1,29 @@ +{-# Language DeriveFunctor, DeriveTraversable, DeriveFoldable #-} +module Unison.Util.Alphabetical where + +import qualified Data.RFC5051 as RFC5051 +import Data.Text (Text) + +-- Alphabetical ordering used for sorting things to display to humans. +-- Should have 'A' and 'a' both come before 'B' and 'b', etc. +-- +-- This need not coincide with the `Ord` instance for a type, which +-- is often an efficient yet arbitrary ordering that's used for +-- stashing the values in maps and sets. +class Eq n => Alphabetical n where + compareAlphabetical :: n -> n -> Ordering + +instance Alphabetical Text where + compareAlphabetical = RFC5051.compareUnicode + +-- newtype whose Ord instance uses alphabetical ordering +newtype OrderAlphabetically a = OrderAlphabetically a deriving (Functor,Traversable,Foldable,Eq) + +instance (Eq a, Alphabetical a) => Ord (OrderAlphabetically a) where + compare (OrderAlphabetically a) (OrderAlphabetically b) = compareAlphabetical a b + +instance Alphabetical a => Alphabetical [a] where + compareAlphabetical a1s a2s = compare (OrderAlphabetically <$> a1s) (OrderAlphabetically <$> a2s) + +instance Alphabetical a => Alphabetical (Maybe a) where + compareAlphabetical a1s a2s = compare (OrderAlphabetically <$> a1s) (OrderAlphabetically <$> a2s) diff --git a/unison-core/src/Unison/Util/Relation.hs b/unison-core/src/Unison/Util/Relation.hs index 0d295b0448..0c03906447 100644 --- a/unison-core/src/Unison/Util/Relation.hs +++ b/unison-core/src/Unison/Util/Relation.hs @@ -9,6 +9,7 @@ import qualified Data.List as List import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Map as Map +import qualified Data.Map.Internal as Map import qualified Unison.Hashable as H import qualified Control.Monad as Monad @@ -409,6 +410,43 @@ lookupRan b r = fromMaybe S.empty $ lookupRan' b r lookupDom :: Ord a => a -> Relation a b -> Set b lookupDom a r = fromMaybe S.empty $ lookupDom' a r +-- Efficiently locate the `Set b` for which the corresponding `a` tests +-- as `EQ` according to the provided function `f`, assuming that such +-- elements are contiguous via the `Ord a`. That is, `f <$> toList (dom r)` +-- must look something like [LT,LT,EQ,EQ,EQ,GT], or more generally, 0 or +-- more LT followed by 0 or more EQ, followed by 0 or more GT. +-- +-- For example, given a `Relation (Int,y) z`, +-- `searchDom (\(i,_) -> compare i 10)` will return all the `z` whose +-- associated `(Int,y)` is of the form `(10,y)` for any choice of `y`. +-- +-- Takes logarithmic time to find the smallest `amin` such that `f a == EQ`, +-- and the largest `amax` such that `f amax == EQ`. The rest of the runtime is +-- just assembling the returned `Set b`, so when the returned `Set b` is small +-- or empty, this function takes time logarithmic in the number of unique keys +-- of the domain, `a`. +searchDom :: (Ord a, Ord b) => (a -> Ordering) -> Relation a b -> Set b +searchDom f r = go (domain r) where + go Map.Tip = mempty + go (Map.Bin _ amid bs l r) = case f amid of + EQ -> bs <> goL l <> goR r + LT -> go r + GT -> go l + goL Map.Tip = mempty + goL (Map.Bin _ amid bs l r) = case f amid of + EQ -> bs <> goL l <> S.unions (Map.elems r) + LT -> goL r + GT -> error "predicate not monotone with respect to ordering" + goR Map.Tip = mempty + goR (Map.Bin _ amid bs l r) = case f amid of + EQ -> bs <> goR r <> S.unions (Map.elems l) + GT -> goR l + LT -> error "predicate not monotone with respect to ordering" + +-- Like `searchDom`, but searches the `b` of this `Relation`. +searchRan :: (Ord a, Ord b) => (b -> Ordering) -> Relation a b -> Set a +searchRan f r = searchDom f (swap r) + replaceDom :: (Ord a, Ord b) => a -> a -> Relation a b -> Relation a b replaceDom a a' r = foldl' (\r b -> insert a' b $ delete a b r) r (lookupDom a r) diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index f99c297ac6..2ffb55b4a7 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -11,10 +11,11 @@ import Data.Text (pack) import qualified Data.Text as Text import qualified Unison.ABT as ABT import qualified Unison.NameSegment as Name +import Unison.WatchKind import Unison.Util.Monoid (intercalateMap) -import Unison.Reference (Reference) -import qualified Unison.Reference as R +-- import Unison.Reference (Reference) +-- import qualified Unison.Reference as R -- | A class for variables. Variables may have auxiliary information which -- may not form part of their identity according to `Eq` / `Ord`. Laws: @@ -34,10 +35,6 @@ freshIn = ABT.freshIn named :: Var v => Text -> v named n = typed (User n) --- | Variable whose name is derived from the given reference. -refNamed :: Var v => Reference -> v -refNamed ref = named ("ℍ" <> R.toText ref) - rawName :: Type -> Text rawName typ = case typ of User n -> n @@ -120,11 +117,6 @@ data Type | Irrelevant deriving (Eq,Ord,Show) -type WatchKind = String - -pattern RegularWatch = "" -pattern TestWatch = "test" - data InferenceType = Ability | Input | Output | PatternPureE | PatternPureV | diff --git a/unison-core/src/Unison/Var/RefNamed.hs b/unison-core/src/Unison/Var/RefNamed.hs new file mode 100644 index 0000000000..f963f6e9d0 --- /dev/null +++ b/unison-core/src/Unison/Var/RefNamed.hs @@ -0,0 +1,13 @@ +{-# Language OverloadedStrings #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} + +module Unison.Var.RefNamed where + +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Var (Var) +import qualified Unison.Var as Var + +refNamed :: Var v => Reference -> v +refNamed ref = Var.named ("ℍ" <> Reference.toText ref) \ No newline at end of file diff --git a/unison-core/src/Unison/WatchKind.hs b/unison-core/src/Unison/WatchKind.hs new file mode 100644 index 0000000000..dccceedb88 --- /dev/null +++ b/unison-core/src/Unison/WatchKind.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.WatchKind where + +type WatchKind = String + +pattern RegularWatch = "" +pattern TestWatch = "test" diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 57d93f9a38..5b2c5e5958 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6eae706c8674f4a7f22bb4bff150798cdaba8aa9186b3d94a6a8467a9cc23d06 +-- hash: 3dc00080efb41dcfb41dd8f03bea8ab3e2550a41a92fe1962b9210b52393ce88 name: unison-core1 version: 0.0.0 @@ -30,6 +30,8 @@ library Unison.Blank Unison.ConstructorType Unison.DataDeclaration + Unison.DataDeclaration.ConstructorId + Unison.DataDeclaration.Names Unison.Hash Unison.Hashable Unison.HashQualified @@ -37,21 +39,24 @@ library Unison.Kind Unison.LabeledDependency Unison.Name + Unison.Names.ResolutionResult Unison.Names2 Unison.Names3 Unison.NameSegment Unison.Paths Unison.Pattern - Unison.PatternCompat Unison.Prelude Unison.Reference Unison.Reference.Util Unison.Referent + Unison.Referent' Unison.Settings Unison.ShortHash Unison.Symbol Unison.Term Unison.Type + Unison.Type.Names + Unison.Util.Alphabetical Unison.Util.Components Unison.Util.List Unison.Util.Monoid @@ -60,6 +65,8 @@ library Unison.Util.Relation4 Unison.Util.Set Unison.Var + Unison.Var.RefNamed + Unison.WatchKind other-modules: Paths_unison_core1 hs-source-dirs: From b2731996d337400a9dc0dcd22626f32ade5a8edc Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 12:24:36 -0400 Subject: [PATCH 018/148] delete FileCodebase and DebugBranchHistoryI --- .../src/Unison/Codebase/Editor/HandleInput.hs | 1 - .../src/Unison/Codebase/Editor/Input.hs | 1 - .../src/Unison/Codebase/FileCodebase.hs | 334 ----- .../Unison/Codebase/FileCodebase/Branch.hs | 783 ------------ .../FileCodebase/Branch/Dependencies.hs | 99 -- .../Unison/Codebase/FileCodebase/Codebase.hs | 109 -- .../Unison/Codebase/FileCodebase/Common.hs | 606 --------- .../Codebase/FileCodebase/DataDeclaration.hs | 117 -- .../src/Unison/Codebase/FileCodebase/Init.hs | 27 - .../FileCodebase/LabeledDependency.hs | 56 - .../Unison/Codebase/FileCodebase/Metadata.hs | 80 -- .../src/Unison/Codebase/FileCodebase/Patch.hs | 136 -- .../Unison/Codebase/FileCodebase/Pattern.hs | 165 --- .../Unison/Codebase/FileCodebase/Reference.hs | 192 --- .../Codebase/FileCodebase/Reference/Util.hs | 21 - .../Unison/Codebase/FileCodebase/Referent.hs | 124 -- .../Codebase/FileCodebase/Serialization/V1.hs | 790 ------------ .../FileCodebase/SlimCopyRegenerateIndex.hs | 322 ----- .../src/Unison/Codebase/FileCodebase/Term.hs | 1120 ----------------- .../Unison/Codebase/FileCodebase/TermEdit.hs | 42 - .../src/Unison/Codebase/FileCodebase/Type.hs | 709 ----------- .../Unison/Codebase/FileCodebase/TypeEdit.hs | 20 - .../src/Unison/Codebase/Type.hs | 2 - .../src/Unison/CommandLine/InputPatterns.hs | 7 - parser-typechecker/tests/Unison/Test/Ucm.hs | 1 - .../unison-parser-typechecker.cabal | 20 - parser-typechecker/unison/Main.hs | 3 +- 27 files changed, 1 insertion(+), 5886 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index d6ca11e578..3ae75e1f69 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -469,7 +469,6 @@ loop = do ShowDefinitionByPrefixI{} -> wat ShowReflogI{} -> wat DebugNumberedArgsI{} -> wat - DebugBranchHistoryI{} -> wat DebugTypecheckedUnisonFileI{} -> wat DebugDumpNamespacesI{} -> wat DebugClearWatchI {} -> wat diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 978762b838..517dad757a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -135,7 +135,6 @@ data Input | ListDependenciesI (HQ.HashQualified Name) | ListDependentsI (HQ.HashQualified Name) | DebugNumberedArgsI - | DebugBranchHistoryI | DebugTypecheckedUnisonFileI | DebugDumpNamespacesI | DebugClearWatchI diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs deleted file mode 100644 index 99e56a4aef..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs +++ /dev/null @@ -1,334 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase - ( codebase1', -- used by Test/Git - Unison.Codebase.FileCodebase.init, - openCodebase, -- since init requires a bunch of irrelevant args now - ) -where - -import Control.Concurrent (forkIO, killThread) -import Control.Exception.Safe (MonadCatch, catchIO) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.Extra ((||^)) -import Control.Monad.Trans.Except (withExceptT) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.IO as TextIO -import System.Directory (canonicalizePath) -import System.FilePath (dropExtension, ()) -import qualified U.Util.Cache as Cache -import U.Util.Timing (time) -import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation) -import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch, withIOError, withStatus) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), printWriteRepo, writeToRead) -import Unison.Codebase.FileCodebase.Branch (Branch, headHash) -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import Unison.Codebase.FileCodebase.Codebase (Codebase (Codebase), CodebasePath, GitError (GitCodebaseError, GitFileCodebaseError, GitProtocolError)) -import qualified Unison.Codebase.FileCodebase.Codebase as Codebase -import Unison.Codebase.Causal (RawHash(RawHash)) -import Unison.Codebase.FileCodebase.Common - ( Err (CantParseBranchHead), - branchFromFiles, - branchHashesByPrefix, - branchHeadDir, - codebaseExists, - codebasePath, - componentIdFromString, - decodeFileName, - dependentsDir, - failWith, - formatAnn, - getDecl, - getPatch, - getRootBranch, - getTerm, - getTypeOfTerm, - getWatch, - hashExists, - hashFromFilePath, - listDirectory, - patchExists, - putBranch, - putDecl, - putRootBranch, - putTerm, - putWatch, - referentIdFromString, - reflogPath, - serializeEdits, - termReferencesByPrefix, - termReferentsByPrefix, - typeIndexDir, - typeMentionsIndexDir, - typeReferencesByPrefix, - updateCausalHead, - watchesDir, - ) -import qualified Unison.Codebase.FileCodebase.Common as Common -import qualified Unison.Codebase.FileCodebase.Init as Codebase (CreateCodebaseError (..), Init (Init), Pretty) -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 (formatSymbol) -import qualified Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex as Sync -import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Reflog as Reflog (Entry (..), fromText, toText) -import qualified Unison.Codebase.Serialization as S (Format (..)) -import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.Codebase.Watch as Watch (collectUntilPause, watchDirectory') -import Unison.Parser.Ann (Ann) -import Unison.Prelude -import Unison.Symbol (Symbol) -import qualified Unison.Util.Pretty as P -import qualified Unison.Util.TQueue as TQueue -import Unison.Var (Var) -import Unison.WatchKind (WatchKind) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) -import UnliftIO.STM (atomically) -import qualified Unison.Codebase.GitError as GitError -init :: (MonadIO m, MonadCatch m) => Codebase.Init m Symbol Ann -init = Codebase.Init - (const $ (fmap . fmap) (pure (),) . openCodebase) - (const $ (fmap . fmap) (pure (),) . createCodebase) - ( Common.codebasePath) - - --- get the codebase in dir -openCodebase :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m (Either Codebase.Pretty (Codebase m Symbol Ann)) -openCodebase dir = do - prettyDir <- liftIO $ P.string <$> canonicalizePath dir - let theCodebase = codebase1 @m @Symbol @Ann Cache.nullCache V1.formatSymbol formatAnn dir - ifM (codebaseExists dir) - (Right <$> theCodebase) - (pure . Left $ "No FileCodebase structure found at " <> prettyDir) - -createCodebase :: - forall m. - (MonadIO m, MonadCatch m) => - CodebasePath -> - m (Either Codebase.CreateCodebaseError (Codebase m Symbol Ann)) -createCodebase dir = ifM - (codebaseExists dir) - (pure $ Left Codebase.CreateCodebaseAlreadyExists) - (do - codebase <- codebase1 @m @Symbol @Ann Cache.nullCache V1.formatSymbol formatAnn dir - Codebase.putRootBranch codebase Branch.empty - pure $ Right codebase) - --- builds a `Codebase IO v a`, given serializers for `v` and `a` -codebase1 - :: forall m v a - . MonadIO m - => MonadCatch m - => Var v - => BuiltinAnnotation a - => Branch.Cache m -> S.Format v -> S.Format a -> CodebasePath -> m (Codebase m v a) -codebase1 = codebase1' Sync.syncToDirectory - -codebase1' - :: forall m v a - . MonadIO m - => MonadCatch m - => Var v - => BuiltinAnnotation a - => Common.SyncToDir m v a -> Branch.Cache m -> S.Format v -> S.Format a -> CodebasePath -> m (Codebase m v a) -codebase1' syncToDirectory branchCache fmtV@(S.Format getV putV) fmtA@(S.Format getA putA) path = do - termCache <- Cache.semispaceCache 8192 - typeOfTermCache <- Cache.semispaceCache 8192 - declCache <- Cache.semispaceCache 1024 - let addDummyCleanup (a,b) = (pure (), a, b) - c = - Codebase - (Cache.applyDefined termCache $ getTerm getV getA path) - (Cache.applyDefined typeOfTermCache $ getTypeOfTerm getV getA path) - (Cache.applyDefined declCache $ getDecl getV getA path) - (putTerm putV putA path) - (putDecl putV putA path) - (getRootBranch branchCache path) - (putRootBranch path) - (branchHeadUpdates path) - (branchFromFiles branchCache path) - (putBranch path) - (hashExists path) - (getPatch path) - (\h p -> serializeEdits path h (pure p)) - (patchExists path) - dependents - (flip (syncToDirectory fmtV fmtA) path) - (syncToDirectory fmtV fmtA path) - (runExceptT . fmap addDummyCleanup . viewRemoteBranch' Cache.nullCache) - (\b r m -> runExceptT $ - pushGitRootBranch (syncToDirectory fmtV fmtA path) Cache.nullCache b r m) - watches - (getWatch getV getA path) - (putWatch putV putA path) - (removeDirectoryRecursive $ path codebasePath "watches") - getReflog - appendReflog - getTermsOfType - getTermsMentioningType - -- todo: maintain a trie of references to come up with this number - (pure 10) - -- The same trie can be used to make this lookup fast: - (termReferencesByPrefix path) - (typeReferencesByPrefix path) - (termReferentsByPrefix (getDecl getV getA) path) - (pure 10) - (branchHashesByPrefix path) - Nothing -- just use in memory Branch.lca - Nothing -- just use in memory Branch.before - in pure c - where - dependents :: Reference -> m (Set Reference.Id) - dependents r = listDirAsIds (dependentsDir path r) - getTermsOfType :: Reference -> m (Set Referent.Id) - getTermsOfType r = listDirAsReferents (typeIndexDir path r) - getTermsMentioningType :: Reference -> m (Set Referent.Id) - getTermsMentioningType r = listDirAsReferents (typeMentionsIndexDir path r) - -- todo: revisit these - listDirAsIds :: FilePath -> m (Set Reference.Id) - listDirAsIds d = do - e <- doesDirectoryExist d - if e - then do - ls <- fmap decodeFileName <$> listDirectory d - pure . Set.fromList $ ls >>= (toList . componentIdFromString) - else pure Set.empty - listDirAsReferents :: FilePath -> m (Set Referent.Id) - listDirAsReferents d = do - e <- doesDirectoryExist d - if e - then do - ls <- fmap decodeFileName <$> listDirectory d - pure . Set.fromList $ ls >>= (toList . referentIdFromString) - else pure Set.empty - watches :: WatchKind -> m [Reference.Id] - watches k = - liftIO $ do - let wp = watchesDir path (Text.pack k) - createDirectoryIfMissing True wp - ls <- listDirectory wp - pure $ ls >>= (toList . componentIdFromString . dropExtension) - getReflog :: m [Reflog.Entry Branch.Hash] - getReflog = - liftIO - (do contents <- TextIO.readFile (reflogPath path) - let lines = Text.lines contents - let entries = parseEntry <$> lines - pure entries) `catchIO` const (pure []) - where - parseEntry t = fromMaybe (err t) (Reflog.fromText t) - err t = error $ - "I couldn't understand this line in " ++ reflogPath path ++ "\n\n" ++ - Text.unpack t - appendReflog :: Text -> Branch m -> Branch m -> m () - appendReflog reason old new = - let - t = Reflog.toText $ - Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason - in liftIO $ TextIO.appendFile (reflogPath path) (t <> "\n") - --- watches in `branchHeadDir root` for externally deposited heads; --- parse them, and return them -branchHeadUpdates - :: MonadIO m => CodebasePath -> m (IO (), IO (Set Branch.Hash)) -branchHeadUpdates root = do - branchHeadChanges <- TQueue.newIO - (cancelWatch, watcher) <- Watch.watchDirectory' (branchHeadDir root) --- -- add .ubf file changes to intermediate queue - watcher1 <- - liftIO . forkIO - $ forever - $ do - -- Q: what does watcher return on a file deletion? - -- A: nothing - (filePath, _) <- watcher - case hashFromFilePath filePath of - Nothing -> failWith $ CantParseBranchHead filePath - Just h -> - atomically . TQueue.enqueue branchHeadChanges $ Branch.Hash h - -- smooth out intermediate queue - pure - ( cancelWatch >> killThread watcher1 - , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 - ) - --- * Git stuff - -viewRemoteBranch' :: forall m. (MonadIO m, MonadCatch m) - => Branch.Cache m -> ReadRemoteNamespace -> ExceptT GitError m (Branch m, CodebasePath) -viewRemoteBranch' cache (repo, sbh, path) = do - -- set up the cache dir - remotePath <- time "Git fetch" . withExceptT GitProtocolError $ pullBranch repo - -- try to load the requested branch from it - branch <- time "Git fetch (sbh)" $ case sbh of - -- load the root branch - Nothing -> lift (getRootBranch cache remotePath) >>= \case - Left Codebase.NoRootBranch -> pure Branch.empty - Left (Codebase.CouldntLoadRootBranch h) -> - throwError . GitCodebaseError $ GitError.CouldntLoadRootBranch repo h - Left (Codebase.CouldntParseRootBranch s) -> - throwError . GitFileCodebaseError $ Codebase.GitCouldntParseRootBranchHash repo s - Right b -> pure b - -- load from a specific `ShortBranchHash` - Just sbh -> do - branchCompletions <- lift $ branchHashesByPrefix remotePath sbh - case toList branchCompletions of - [] -> throwError . GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh - [h] -> (lift $ branchFromFiles cache remotePath h) >>= \case - Just b -> pure b - Nothing -> throwError . GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh - _ -> throwError . GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions - pure (Branch.getAt' path branch, remotePath) - --- Given a branch that is "after" the existing root of a given git repo, --- stage and push the branch (as the new root) + dependencies to the repo. -pushGitRootBranch - :: (MonadIO m, MonadCatch m) - => Codebase.SyncToDir m - -> Branch.Cache m - -> Branch m - -> WriteRepo - -> SyncMode - -> ExceptT GitError m () -pushGitRootBranch syncToDirectory cache branch repo syncMode = do - -- Pull the remote repo into a staging directory - (remoteRoot, remotePath) <- viewRemoteBranch' cache (writeToRead repo, Nothing, Path.empty) - withExceptT GitProtocolError $ ifM (pure (remoteRoot == Branch.empty) - ||^ lift (remoteRoot `Branch.before` branch)) - -- ours is newer 👍, meaning this is a fast-forward push, - -- so sync branch to staging area - (stageAndPush remotePath) - (throwError $ GitError.PushDestinationHasNewStuff repo) - where - stageAndPush remotePath = do - let repoString = Text.unpack $ printWriteRepo repo - withStatus ("Staging files for upload to " ++ repoString ++ " ...") $ - lift (syncToDirectory remotePath syncMode branch) - updateCausalHead (branchHeadDir remotePath) (Branch._history branch) - -- push staging area to remote - withStatus ("Uploading to " ++ repoString ++ " ...") $ - unlessM - (push remotePath repo - `withIOError` (throwError . GitError.PushException repo . show)) - (throwError $ GitError.PushNoOp repo) - -- Commit our changes - push :: CodebasePath -> WriteRepo -> IO Bool -- withIOError needs IO - push remotePath (WriteGitRepo url) = do - -- has anything changed? - status <- gitTextIn remotePath ["status", "--short"] - if Text.null status then - pure False - else do - gitIn remotePath ["add", "--all", "."] - gitIn remotePath - ["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ headHash branch)] - -- Push our changes to the repo - gitIn remotePath ["push", "--quiet", url] - pure True diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs deleted file mode 100644 index 1325ad6ada..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch.hs +++ /dev/null @@ -1,783 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} - -module Unison.Codebase.FileCodebase.Branch - ( -- * Branch types - Branch(..) - , UnwrappedBranch - , Branch0(..) - , Raw(..) - , Star - , Hash - , EditHash - , pattern Hash - -- * Branch construction - , empty - , branch0 - , toCausalRaw - , transform - , headHash - , before - , merge - -- ** Children lenses - , children - -- ** Children queries - , getAt' - -- * Branch terms/types/edits - -- ** Term/type/edits lenses - , terms - , types - , edits - -- * Branch serialization - , cachedRead - , Cache - , sync - ) where - -import Unison.Prelude hiding (empty) - -import Prelude hiding (head,read,subtract) - -import Control.Lens hiding ( children, cons, transform, uncons ) -import qualified Control.Monad.State as State -import Control.Monad.State ( StateT ) -import Data.Bifunctor ( second ) -import qualified Data.Map as Map -import qualified Data.Map.Merge.Lazy as Map -import qualified Data.Set as Set -import qualified Unison.Codebase.FileCodebase.Patch as Patch -import Unison.Codebase.FileCodebase.Patch (Patch) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Causal ( Causal - , pattern RawOne - , pattern RawCons - , pattern RawMerge - ) -import Unison.Codebase.Path ( Path(..) ) -import qualified Unison.Codebase.Path as Path -import Unison.NameSegment ( NameSegment ) -import qualified Unison.NameSegment as NameSegment -import qualified Unison.Codebase.FileCodebase.Metadata as Metadata -import qualified Unison.Hash as Hash -import Unison.Hashable ( Hashable ) -import qualified Unison.Hashable as H -import Unison.Name ( Name(..) ) -import qualified Unison.Name as Name -import Unison.Codebase.FileCodebase.Reference (Reference) -import Unison.Codebase.FileCodebase.Referent (Referent) - -import qualified U.Util.Cache as Cache -import qualified Unison.Util.Relation as R -import Unison.Util.Relation ( Relation ) -import qualified Unison.Util.Relation4 as R4 -import Unison.Util.Map ( unionWithM ) -import qualified Unison.Util.Star3 as Star3 - --- | 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) - -type Hash = Causal.RawHash Raw -type EditHash = Hash.Hash - -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` - , deepTerms :: Relation Referent Name - , deepTypes :: Relation Reference Name - , deepTermMetadata :: Metadata.R4 Referent Name - , deepTypeMetadata :: Metadata.R4 Reference Name - , deepPaths :: Set Path - , deepEdits :: Map Name EditHash - } - --- Represents a shallow diff of a Branch0. --- Each of these `Star`s contain metadata as well, so an entry in --- `added` or `removed` could be an update to the metadata. -data BranchDiff = BranchDiff - { addedTerms :: Star Referent NameSegment - , removedTerms :: Star Referent NameSegment - , addedTypes :: Star Reference NameSegment - , removedTypes :: Star Reference NameSegment - , changedPatches :: Map NameSegment Patch.PatchDiff - } deriving (Eq, Ord, Show) - -instance Semigroup BranchDiff where - left <> right = BranchDiff - { addedTerms = addedTerms left <> addedTerms right - , removedTerms = removedTerms left <> removedTerms right - , addedTypes = addedTypes left <> addedTypes right - , removedTypes = removedTypes left <> removedTypes right - , changedPatches = - Map.unionWith (<>) (changedPatches left) (changedPatches right) - } - -instance Monoid BranchDiff where - mappend = (<>) - mempty = BranchDiff mempty mempty mempty mempty mempty - --- The raw Branch -data Raw = Raw - { _termsR :: Star Referent NameSegment - , _typesR :: Star Reference NameSegment - , _childrenR :: Map NameSegment Hash - , _editsR :: Map NameSegment EditHash - } - -makeLenses ''Branch -makeLensesFor [("_edits", "edits")] ''Branch0 - -terms :: Lens' (Branch0 m) (Star Referent NameSegment) -terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) - -types :: Lens' (Branch0 m) (Star Reference NameSegment) -types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) - -children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) -children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) - --- creates a Branch0 from the primary fields and derives the others. -branch0 :: Metadata.Star Referent NameSegment - -> Metadata.Star Reference NameSegment - -> Map NameSegment (Branch m) - -> Map NameSegment (EditHash, m Patch) - -> Branch0 m -branch0 terms types children edits = - Branch0 terms types children edits - deepTerms' deepTypes' - deepTermMetadata' deepTypeMetadata' - deepPaths' deepEdits' - where - nameSegToName = Name.unsafeFromText . NameSegment.toText - deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms - <> foldMap go (Map.toList children) - where - go (nameSegToName -> n, b) = - R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic - deepTypes' = (R.mapRan nameSegToName . Star3.d1) types - <> foldMap go (Map.toList children) - where - go (nameSegToName -> n, b) = - R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic - deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) - <> foldMap go (Map.toList children) - where - go (nameSegToName -> n, b) = - R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) - deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) - <> foldMap go (Map.toList children) - where - go (nameSegToName -> n, b) = - R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) - deepPaths' = Set.map Path.singleton (Map.keysSet children) - <> foldMap go (Map.toList children) - where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) - deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) - <> foldMap go (Map.toList children) - where - go (nameSeg, b) = - Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b - -head :: Branch m -> Branch0 m -head (Branch c) = Causal.head c - -headHash :: Branch m -> Hash -headHash (Branch c) = Causal.currentHash c - --- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) --- deepEdits' b = go id b where --- -- can change this to an actual prefix once Name is a [NameSegment] --- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) --- go addPrefix Branch0{..} = --- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits --- <> foldMap f (Map.toList _children) --- where --- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) --- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) - -data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) - -merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) -merge = merge' RegularMerge - --- Discards the history of a Branch0's children, recursively -discardHistory0 :: Applicative m => Branch0 m -> Branch0 m -discardHistory0 = over children (fmap tweak) where - tweak b = cons (discardHistory0 (head b)) empty - -merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) -merge' = merge'' lca - -merge'' :: forall m . Monad m - => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator - -> MergeMode - -> Branch m - -> Branch m - -> m (Branch m) -merge'' _ _ b1 b2 | isEmpty b1 = pure b2 -merge'' _ mode b1 b2 | isEmpty b2 = case mode of - RegularMerge -> pure b1 - SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 -merge'' lca mode (Branch x) (Branch y) = - Branch <$> case mode of - RegularMerge -> Causal.threeWayMerge' lca' combine x y - SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y - where - lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) - combine Nothing l r = merge0 lca mode l r - combine (Just ca) l r = do - dl <- diff0 ca l - dr <- diff0 ca r - head0 <- apply ca (dl <> dr) - children <- Map.mergeA - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.traverseMaybeMissing $ combineMissing ca) - (Map.zipWithAMatched $ const (merge'' lca mode)) - (_children l) (_children r) - pure $ branch0 (_terms head0) (_types head0) children (_edits head0) - - combineMissing ca k cur = - case Map.lookup k (_children ca) of - Nothing -> pure $ Just cur - Just old -> do - nw <- merge'' lca mode (cons empty0 old) cur - if isEmpty0 $ head nw - then pure Nothing - else pure $ Just nw - - apply :: Branch0 m -> BranchDiff -> m (Branch0 m) - apply b0 BranchDiff {..} = do - patches <- sequenceA - $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches - let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) - makePatch Patch.PatchDiff {..} = - let p = Patch.Patch _addedTermEdits _addedTypeEdits - in (H.accumulate' p, pure p) - pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) - (Star3.difference (_types b0) removedTypes <> addedTypes) - (_children b0) - (patches <> newPatches) - patchMerge mhp Patch.PatchDiff {..} = Just $ do - (_, mp) <- mhp - p <- mp - let np = Patch.Patch - { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits - <> _addedTermEdits - , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits - <> _addedTypeEdits - } - pure (H.accumulate' np, pure np) - --- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- -- It's defined as: lca b1 b2 == Just b1 --- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) --- -> Branch m -> Branch m -> m Bool --- before' lca (Branch x) (Branch y) = Causal.before' lca' x y --- where --- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - --- `before b1 b2` is true if `b2` incorporates all of `b1` -before :: Monad m => Branch m -> Branch m -> m Bool -before (Branch b1) (Branch b2) = Causal.before b1 b2 - -merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) - -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) -merge0 lca mode b1 b2 = do - c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) - e3 <- unionWithM g (_edits b1) (_edits b2) - pure $ branch0 (_terms b1 <> _terms b2) - (_types b1 <> _types b2) - c3 - e3 - where - g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) - g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) - g (_, m1) (_, m2) = do - e1 <- m1 - e2 <- m2 - let e3 = e1 <> e2 - pure (H.accumulate' e3, pure e3) - -pattern Hash h = Causal.RawHash h - --- toList0 :: Branch0 m -> [(Path, Branch0 m)] --- toList0 = go Path.empty where --- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> --- go (Path.snoc p seg) (head cb) )) - --- printDebugPaths :: Branch m -> String --- printDebugPaths = unlines . map show . Set.toList . debugPaths - --- debugPaths :: Branch m -> Set (Path, Hash) --- debugPaths = go Path.empty where --- go p b = Set.insert (p, headHash b) . Set.unions $ --- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] - --- data Target = TargetType | TargetTerm | TargetBranch --- deriving (Eq, Ord, Show) - -instance Eq (Branch0 m) where - a == b = view terms a == view terms b - && view types a == view types b - && view children a == view children b - && (fmap fst . view edits) a == (fmap fst . view edits) b - --- data ForkFailure = SrcNotFound | DestExists - --- -- consider delegating to Names.numHashChars when ready to implement? --- -- are those enough? --- -- could move this to a read-only field in Branch0 --- -- could move a Names0 to a read-only field in Branch0 until it gets too big --- numHashChars :: Branch m -> Int --- numHashChars _b = 3 - --- This type is a little ugly, so we wrap it up with a nice type alias for --- use outside this module. -type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) - --- boundedCache :: MonadIO m => Word -> m (Cache m2) --- boundedCache = Cache.semispaceCache - --- Can use `Cache.nullCache` to disable caching if needed -cachedRead :: forall m . MonadIO m - => Cache m - -> Causal.Deserialize m Raw Raw - -> (EditHash -> m Patch) - -> Hash - -> m (Branch m) -cachedRead cache deserializeRaw deserializeEdits h = - Branch <$> Causal.cachedRead cache d h - where - fromRaw :: Raw -> m (Branch0 m) - fromRaw Raw {..} = do - children <- traverse go _childrenR - edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash - pure $ branch0 _termsR _typesR children edits - go = cachedRead cache deserializeRaw deserializeEdits - d :: Causal.Deserialize m Raw (Branch0 m) - d h = deserializeRaw h >>= \case - RawOne raw -> RawOne <$> fromRaw raw - RawCons raw h -> flip RawCons h <$> fromRaw raw - RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw - -sync - :: Monad m - => (Hash -> m Bool) - -> Causal.Serialize m Raw Raw - -> (EditHash -> m Patch -> m ()) - -> Branch m - -> m () -sync exists serializeRaw serializeEdits b = do - _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty - -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." - pure () - --- serialize a `Branch m` indexed by the hash of its corresponding Raw -sync' - :: forall m - . Monad m - => (Hash -> m Bool) - -> Causal.Serialize m Raw Raw - -> (EditHash -> m Patch -> m ()) - -> Branch m - -> StateT (Set Hash) m () -sync' exists serializeRaw serializeEdits b = Causal.sync exists - serialize0 - (view history b) - where - serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) - serialize0 h b0 = case b0 of - RawOne b0 -> do - writeB0 b0 - lift $ serializeRaw h $ RawOne (toRaw b0) - RawCons b0 ht -> do - writeB0 b0 - lift $ serializeRaw h $ RawCons (toRaw b0) ht - RawMerge b0 hs -> do - writeB0 b0 - lift $ serializeRaw h $ RawMerge (toRaw b0) hs - where - writeB0 :: Branch0 m -> StateT (Set Hash) m () - writeB0 b0 = do - for_ (view children b0) $ \c -> do - queued <- State.get - when (Set.notMember (headHash c) queued) $ - sync' exists serializeRaw serializeEdits c - for_ (view edits b0) (lift . uncurry serializeEdits) - - -- this has to serialize the branch0 and its descendants in the tree, - -- and then serialize the rest of the history of the branch as well - -toRaw :: Branch0 m -> Raw -toRaw Branch0 {..} = - Raw _terms _types (headHash <$> _children) (fst <$> _edits) - -toCausalRaw :: Branch m -> Causal.Raw Raw Raw -toCausalRaw = \case - Branch (Causal.One _h e) -> RawOne (toRaw e) - Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht - Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) - --- -- copy a path to another path --- fork --- :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- fork src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> case setIfNotExists dest src' root of --- Nothing -> Left DestExists --- Just root' -> Right root' - --- -- Move the node at src to dest. --- -- It's okay if `dest` is inside `src`, just create empty levels. --- -- Try not to `step` more than once at each node. --- move :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- move src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> --- -- make sure dest doesn't already exist --- case getAt dest root of --- Just _destExists -> Left DestExists --- Nothing -> --- -- find and update common ancestor of `src` and `dest`: --- Right $ modifyAt ancestor go root --- where --- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest --- go = deleteAt relSrc . setAt relDest src' - --- setIfNotExists --- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) --- setIfNotExists dest b root = case getAt dest root of --- Just _destExists -> Nothing --- Nothing -> Just $ setAt dest b root - --- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m --- setAt path b = modifyAt path (const b) - --- deleteAt :: Applicative m => Path -> Branch m -> Branch m --- deleteAt path = setAt path empty - --- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` -getAt :: Path - -> Branch m - -> Maybe (Branch m) -getAt path root = case Path.uncons path of - Nothing -> if isEmpty root then Nothing else Just root - Just (seg, path) -> case Map.lookup seg (_children $ head root) of - Just b -> getAt path b - Nothing -> Nothing - -getAt' :: Path -> Branch m -> Branch m -getAt' p b = fromMaybe empty $ getAt p b - --- getAt0 :: Path -> Branch0 m -> Branch0 m --- getAt0 p b = case Path.uncons p of --- Nothing -> b --- Just (seg, path) -> case Map.lookup seg (_children b) of --- Just c -> getAt0 path (head c) --- Nothing -> empty0 - -empty :: Branch m -empty = Branch $ Causal.one empty0 - --- one :: Branch0 m -> Branch m --- one = Branch . Causal.one - -empty0 :: Branch0 m -empty0 = - Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty - -isEmpty0 :: Branch0 m -> Bool -isEmpty0 = (== empty0) - -isEmpty :: Branch m -> Bool -isEmpty = (== empty) - -step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m -step f = \case - Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) - b -> over history (Causal.stepDistinct f) b - --- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepM f = \case --- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 --- b -> mapMOf history (Causal.stepDistinctM f) b - -cons :: Applicative m => Branch0 m -> Branch m -> Branch m -cons = step . const - --- isOne :: Branch m -> Bool --- isOne (Branch Causal.One{}) = True --- isOne _ = False - --- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) --- uncons (Branch b) = go <$> Causal.uncons b where --- go = over (_Just . _2) Branch - --- -- Modify the branch0 at the head of at `path` with `f`, --- -- after creating it if necessary. Preserves history. --- stepAt :: forall m. Applicative m --- => Path --- -> (Branch0 m -> Branch0 m) --- -> Branch m -> Branch m --- stepAt p f = modifyAt p g where --- g :: Branch m -> Branch m --- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b - --- stepManyAt :: (Monad m, Foldable f) --- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m --- stepManyAt actions = step (stepManyAt0 actions) - --- -- Modify the branch0 at the head of at `path` with `f`, --- -- after creating it if necessary. Preserves history. --- stepAtM :: forall n m. (Functor n, Applicative m) --- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepAtM p f = modifyAtM p g where --- g :: Branch m -> n (Branch m) --- g (Branch b) = do --- b0' <- f (Causal.head b) --- pure $ Branch . Causal.consDistinct b0' $ b - --- stepManyAtM :: (Monad m, Monad n, Foldable f) --- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepManyAtM actions = stepM (stepManyAt0M actions) - --- -- starting at the leaves, apply `f` to every level of the branch. --- stepEverywhere --- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) --- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) --- where children = fmap (step $ stepEverywhere f) _children - --- -- Creates a function to fix up the children field._1 --- -- If the action emptied a child, then remove the mapping, --- -- otherwise update it. --- -- Todo: Fix this in hashing & serialization instead of here? --- getChildBranch :: NameSegment -> Branch0 m -> Branch m --- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) - --- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m --- setChildBranch seg b = over children (updateChildren seg b) - --- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch --- getPatch seg b = case Map.lookup seg (_edits b) of --- Nothing -> pure Patch.empty --- Just (_, p) -> p - --- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) --- getMaybePatch seg b = case Map.lookup seg (_edits b) of --- Nothing -> pure Nothing --- Just (_, p) -> Just <$> p - --- modifyPatches --- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) --- modifyPatches seg f = mapMOf edits update --- where --- update m = do --- p' <- case Map.lookup seg m of --- Nothing -> pure $ f Patch.empty --- Just (_, p) -> f <$> p --- let h = H.accumulate' p' --- pure $ Map.insert seg (h, pure p') m - --- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m --- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) - --- deletePatch :: NameSegment -> Branch0 m -> Branch0 m --- deletePatch n = over edits (Map.delete n) - --- updateChildren ::NameSegment --- -> Branch m --- -> Map NameSegment (Branch m) --- -> Map NameSegment (Branch m) --- updateChildren seg updatedChild = --- if isEmpty updatedChild --- then Map.delete seg --- else Map.insert seg updatedChild - --- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- Because it's a `Branch`, it overwrites the history at `path`. --- modifyAt :: Applicative m --- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m --- modifyAt path f = runIdentity . modifyAtM path (pure . f) - --- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- Because it's a `Branch`, it overwrites the history at `path`. --- modifyAtM --- :: forall n m --- . Functor n --- => Applicative m -- because `Causal.cons` uses `pure` --- => Path --- -> (Branch m -> n (Branch m)) --- -> Branch m --- -> n (Branch m) --- modifyAtM path f b = case Path.uncons path of --- Nothing -> f b --- Just (seg, path) -> do -- Functor --- let child = getChildBranch seg (head b) --- child' <- modifyAtM path f child --- -- step the branch by updating its children according to fixup --- pure $ step (setChildBranch seg child') b - --- -- stepManyAt0 consolidates several changes into a single step --- stepManyAt0 :: forall f m . (Monad m, Foldable f) --- => f (Path, Branch0 m -> Branch0 m) --- -> Branch0 m -> Branch0 m --- stepManyAt0 actions = --- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] - --- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) --- => f (Path, Branch0 m -> n (Branch0 m)) --- -> Branch0 m -> n (Branch0 m) --- stepManyAt0M actions b = go (toList actions) b where --- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) --- go actions b = let --- -- combines the functions that apply to this level of the tree --- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] - --- -- groups the actions based on the child they apply to --- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] --- childActions = --- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] - --- -- alters the children of `b` based on the `childActions` map --- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) --- stepChildren children0 = foldM g children0 $ Map.toList childActions --- where --- g children (seg, actions) = do --- -- Recursively applies the relevant actions to the child branch --- -- The `findWithDefault` is important - it allows the stepManyAt --- -- to create new children at paths that don't previously exist. --- child <- stepM (go actions) (Map.findWithDefault empty seg children0) --- pure $ updateChildren seg child children --- in do --- c2 <- stepChildren (view children b) --- currentAction (set children c2 b) - -instance Hashable (Branch0 m) where - tokens b = - [ H.accumulateToken (_terms b) - , H.accumulateToken (_types b) - , H.accumulateToken (headHash <$> _children b) - , H.accumulateToken (fst <$> _edits b) - ] - --- -- getLocalBranch :: Hash -> IO Branch --- -- getGithubBranch :: RemotePath -> IO Branch --- -- getLocalEdit :: GUID -> IO Patch - --- -- todo: consider inlining these into Actions2 --- addTermName --- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- addTermName r new md = --- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- addTypeName --- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- addTypeName r new md = --- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m --- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m - --- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m --- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) --- = over terms (Star3.deletePrimaryD1 (r,n)) b --- deleteTermName _ _ b = b - --- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m --- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) --- = over types (Star3.deletePrimaryD1 (r,n)) b --- deleteTypeName _ _ b = b - --- namesDiff :: Branch m -> Branch m -> Names.Diff --- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) - -lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) -lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b - -diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff -diff0 old new = do - newEdits <- sequenceA $ snd <$> _edits new - oldEdits <- sequenceA $ snd <$> _edits old - let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) - (Map.mapMissing $ \_ p -> Patch.diff mempty p) - (Map.zipWithMatched (const Patch.diff)) - newEdits - oldEdits - pure $ BranchDiff - { addedTerms = Star3.difference (_terms new) (_terms old) - , removedTerms = Star3.difference (_terms old) (_terms new) - , addedTypes = Star3.difference (_types new) (_types old) - , removedTypes = Star3.difference (_types old) (_types new) - , changedPatches = diffEdits - } - -transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n -transform f b = case _history b of - causal -> Branch . Causal.transform f $ transformB0s f causal - where - transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n - transformB0 f b = - b { _children = transform f <$> _children b - , _edits = second f <$> _edits b - } - - transformB0s :: Functor m => (forall a . m a -> n a) - -> Causal m Raw (Branch0 m) - -> Causal m Raw (Branch0 n) - transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) - --- data BranchAttentions = BranchAttentions --- { -- Patches that were edited on the right but entirely removed on the left. --- removedPatchEdited :: [Name] --- -- Patches that were edited on the left but entirely removed on the right. --- , editedPatchRemoved :: [Name] --- } - --- instance Semigroup BranchAttentions where --- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 --- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - --- instance Monoid BranchAttentions where --- mempty = BranchAttentions [] [] --- mappend = (<>) - --- data RefCollisions = --- RefCollisions { termCollisions :: Relation Name Name --- , typeCollisions :: Relation Name Name --- } deriving (Eq, Show) - --- instance Semigroup RefCollisions where --- (<>) = mappend --- instance Monoid RefCollisions where --- mempty = RefCollisions mempty mempty --- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) --- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs deleted file mode 100644 index 4edfb34f9c..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Branch/Dependencies.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.FileCodebase.Branch.Dependencies - ( Branches, - Dependencies (..), - Dependencies' (..), - to', - fromRawCausal, - fromBranch, - ) -where -import Data.Foldable (toList) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid.Generic -import Data.Set (Set) -import qualified Data.Set as Set -import GHC.Generics (Generic) -import Unison.Codebase.FileCodebase.Branch (Branch (Branch), Branch0, EditHash) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import Unison.Codebase.FileCodebase.Patch (Patch) -import Unison.Codebase.FileCodebase.Reference (Reference (DerivedId)) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import Unison.Codebase.FileCodebase.Referent (Referent) -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import Unison.NameSegment (NameSegment) -import qualified Unison.Util.Relation as R -import qualified Unison.Util.Star3 as Star3 -type Branches m = [(Branch.Hash, Maybe (m (Branch m)))] - -data Dependencies = Dependencies - { patches :: Set EditHash - , terms :: Set Reference.Id - , decls :: Set Reference.Id - } - deriving Show - deriving Generic - deriving Semigroup via GenericSemigroup Dependencies - deriving Monoid via GenericMonoid Dependencies - -data Dependencies' = Dependencies' - { patches' :: [EditHash] - , terms' :: [Reference.Id] - , decls' :: [Reference.Id] - } - deriving Show - deriving Generic - deriving Semigroup via GenericSemigroup Dependencies' - deriving Monoid via GenericMonoid Dependencies' - -to' :: Dependencies -> Dependencies' -to' Dependencies{..} = Dependencies' (toList patches) (toList terms) (toList decls) - -fromBranch :: Applicative m => Branch m -> (Branches m, Dependencies) -fromBranch (Branch c) = case c of - Causal.One _hh e -> fromBranch0 e - Causal.Cons _hh e (h, m) -> fromBranch0 e <> fromTails (Map.singleton h m) - Causal.Merge _hh e tails -> fromBranch0 e <> fromTails tails - where - fromTails m = ([(h, Just (Branch <$> mc)) | (h, mc) <- Map.toList m], mempty) - -fromRawCausal :: Causal.Raw Branch.Raw (Branches m, Dependencies) - -> (Branches m, Dependencies) -fromRawCausal = \case - Causal.RawOne e -> e - Causal.RawCons e h -> e <> fromTails [h] - Causal.RawMerge e hs -> e <> fromTails (toList hs) - where - fromTails ts = (fmap (,Nothing) ts, mempty) - -fromBranch0 :: Applicative m => Branch0 m -> (Branches m, Dependencies) -fromBranch0 b = - ( fromChildren (Branch._children b) - , fromTermsStar (Branch._terms b) - <> fromTypesStar (Branch._types b) - <> fromEdits (Branch._edits b) ) - where - fromChildren :: Applicative m => Map NameSegment (Branch m) -> Branches m - fromChildren m = [ (Branch.headHash b, Just (pure b)) | b <- toList m ] - references :: Branch.Star r NameSegment -> [r] - references = toList . R.dom . Star3.d1 - mdValues :: Branch.Star r NameSegment -> [Reference] - mdValues = fmap snd . toList . R.ran . Star3.d3 - fromTermsStar :: Branch.Star Referent NameSegment -> Dependencies - fromTermsStar s = Dependencies mempty terms decls where - terms = Set.fromList $ - [ i | Referent.Ref (DerivedId i) <- references s] ++ - [ i | DerivedId i <- mdValues s] - decls = Set.fromList $ - [ i | Referent.Con (DerivedId i) _ _ <- references s ] - fromTypesStar :: Branch.Star Reference NameSegment -> Dependencies - fromTypesStar s = Dependencies mempty terms decls where - terms = Set.fromList [ i | DerivedId i <- mdValues s ] - decls = Set.fromList [ i | DerivedId i <- references s ] - fromEdits :: Map NameSegment (EditHash, m Patch) -> Dependencies - fromEdits m = Dependencies (Set.fromList . fmap fst $ toList m) mempty mempty diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs deleted file mode 100644 index 743d5392b8..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Codebase.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Codebase - ( Codebase (..), - CodebasePath, - GetRootBranchError (..), - GitError (..), - GitFileCodebaseError (..), - SyncToDir, - ) -where - -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) -import Unison.Codebase.FileCodebase.Branch (Branch) -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import Unison.Codebase.FileCodebase.DataDeclaration (Decl) -import Unison.Codebase.FileCodebase.Patch (Patch) -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import Unison.Codebase.FileCodebase.Term (Term) -import Unison.Codebase.FileCodebase.Type (Type) -import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) -import qualified Unison.Codebase.Reflog as Reflog -import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import Unison.Codebase.SyncMode (SyncMode) -import Unison.CodebasePath (CodebasePath) -import Unison.Prelude -import Unison.ShortHash (ShortHash) -import qualified Unison.WatchKind as WK - -type SyncToDir m = - CodebasePath -> -- dest codebase - SyncMode -> - Branch m -> -- branch to sync to dest codebase - m () - --- | Abstract interface to a user's codebase. --- --- One implementation is 'Unison.Codebase.FileCodebase' which uses the filesystem. -data Codebase m v a = Codebase - { getTerm :: Reference.Id -> m (Maybe (Term v a)), - getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)), - getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), - putTerm :: Reference.Id -> Term v a -> Type v a -> m (), - putTypeDeclaration :: Reference.Id -> Decl v a -> m (), - getRootBranch :: m (Either GetRootBranchError (Branch m)), - putRootBranch :: Branch m -> m (), - rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), - getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)), - putBranch :: Branch m -> m (), - branchExists :: Branch.Hash -> m Bool, - getPatch :: Branch.EditHash -> m (Maybe Patch), - putPatch :: Branch.EditHash -> Patch -> m (), - patchExists :: Branch.EditHash -> m Bool, - dependentsImpl :: Reference -> m (Set Reference.Id), - -- This copies all the dependencies of `b` from the specified Codebase into this one - syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), - -- This copies all the dependencies of `b` from this Codebase - syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), - viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)), - pushGitRootBranch :: Branch m -> WriteRepo -> SyncMode -> m (Either GitError ()), - -- Watch expressions are part of the codebase, the `Reference.Id` is - -- the hash of the source of the watch expression, and the `Term v a` - -- is the evaluated result of the expression, decompiled to a term. - watches :: WK.WatchKind -> m [Reference.Id], - getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)), - putWatch :: WK.WatchKind -> Reference.Id -> Term v a -> m (), - clearWatches :: m (), - getReflog :: m [Reflog.Entry Branch.Hash], - appendReflog :: Text -> Branch m -> Branch m -> m (), - -- list of terms of the given type - termsOfTypeImpl :: Reference -> m (Set Referent.Id), - -- list of terms that mention the given type anywhere in their signature - termsMentioningTypeImpl :: Reference -> m (Set Referent.Id), - -- number of base58 characters needed to distinguish any two references in the codebase - hashLength :: m Int, - termReferencesByPrefix :: ShortHash -> m (Set Reference.Id), - typeReferencesByPrefix :: ShortHash -> m (Set Reference.Id), - termReferentsByPrefix :: ShortHash -> m (Set Referent.Id), - branchHashLength :: m Int, - branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash), - -- returns `Nothing` to not implemented, fallback to in-memory - -- also `Nothing` if no LCA - -- The result is undefined if the two hashes are not in the codebase. - -- Use `Codebase.lca` which wraps this in a nice API. - lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)), - -- `beforeImpl` returns `Nothing` if not implemented by the codebase - -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase - -- - -- Use `Codebase.before` which wraps this in a nice API. - beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) - } - -data GetRootBranchError - = NoRootBranch - | CouldntParseRootBranch FilePath - | CouldntLoadRootBranch Branch.Hash - deriving (Show) - -data GitError - = GitProtocolError GitProtocolError - | GitCodebaseError (GitCodebaseError Branch.Hash) - | GitFileCodebaseError GitFileCodebaseError - -data GitFileCodebaseError - = GitCouldntParseRootBranchHash ReadRepo String - deriving Show \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs deleted file mode 100644 index 39065a17b7..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Common.hs +++ /dev/null @@ -1,606 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Common - ( Err(..) - , SyncToDir - , SimpleLens - , codebaseExists - , codebasePath - , hashExists - -- dirs (parent of all the files) - , branchHeadDir - , dependentsDir - , dependentsDir' - , typeIndexDir - , typeIndexDir' - , typeMentionsIndexDir - , typeMentionsIndexDir' - , watchesDir - -- paths (looking up one file) - , branchPath - , declPath - , editsPath - , reflogPath - , termPath - , typePath - , watchPath - -- core stuff - , formatAnn - , getDecl - , putDecl - , putRootBranch - , getTerm - , getTypeOfTerm - , putTerm - , getWatch - , putWatch - , updateCausalHead - , serializeEdits - , deserializeEdits - , serializeRawBranch - , branchFromFiles - , putBranch - , getPatch - , patchExists - , branchHashesByPrefix - , termReferencesByPrefix - , termReferentsByPrefix - , typeReferencesByPrefix - -- stringing - , hashFromFilePath - , componentIdFromString - , componentIdToString - , referentIdFromString - -- touching files - , touchIdFile - , touchReferentFile - , touchReferentIdFile - -- util - , copyFileWithParents - , doFileOnce - , failWith - , listDirectory - -- expose for tests :| - , encodeFileName - , decodeFileName - , getRootBranch - - ) where - -import Unison.Prelude - -import Control.Error (ExceptT (..), runExceptT) -import Control.Lens (Lens, to, use, (%=)) -import Control.Monad.Catch (catch) -import Control.Monad.State (MonadState) -import qualified Data.ByteString.Base16 as ByteString (decodeBase16, encodeBase16) -import qualified Data.Char as Char -import Data.Either.Extra (maybeToEither) -import Data.List (isPrefixOf) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified System.Directory -import System.FilePath (takeBaseName, takeDirectory, ()) -import U.Util.Timing (time) -import Unison.Codebase (CodebasePath) -import Unison.Codebase.Causal (Causal, RawHash (..)) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.FileCodebase.Branch (Branch) -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import qualified Unison.Codebase.FileCodebase.Codebase as Codebase -import qualified Unison.Codebase.FileCodebase.DataDeclaration as DD -import Unison.Codebase.FileCodebase.Patch (Patch (..)) -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import Unison.Codebase.FileCodebase.Referent (Referent) -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 -import Unison.Codebase.FileCodebase.Term (Term) -import qualified Unison.Codebase.FileCodebase.Term as Term -import Unison.Codebase.FileCodebase.Type (Type) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.Codebase.Serialization as S -import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) -import qualified Unison.Codebase.ShortBranchHash as SBH -import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.ConstructorType as CT -import qualified Unison.Hash as Hash -import Unison.Parser.Ann (Ann (External)) -import qualified Unison.Referent' as Referent -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import Unison.Util.Monoid (foldMapM) -import Unison.Var (Var) -import Unison.WatchKind (WatchKind) -import qualified Unison.WatchKind as WK -import UnliftIO.Directory - ( copyFile, - createDirectoryIfMissing, - doesDirectoryExist, - doesFileExist, - removeFile, - ) -import UnliftIO.IO.File (writeBinaryFile) - -data Err - = InvalidBranchFile FilePath String - | InvalidEditsFile FilePath String - | NoBranchHead FilePath - | CantParseBranchHead FilePath - | AmbiguouslyTypeAndTerm Reference.Id - | UnknownTypeOrTerm Reference - deriving Show - -type SimpleLens s a = Lens s s a a - -codebasePath :: FilePath -codebasePath = ".unison" "v1" - -formatAnn :: S.Format Ann -formatAnn = S.Format (pure External) (\_ -> pure ()) - --- Write Branch and its dependents to the dest codebase -type SyncToDir m v a - = S.Format v - -> S.Format a - -> CodebasePath -- src codebase - -> CodebasePath -- dest codebase - -> SyncMode - -> Branch m -- branch to sync to dest codebase - -> m () - -termsDir, typesDir, branchesDir, branchHeadDir, editsDir - :: CodebasePath -> FilePath -termsDir root = root codebasePath "terms" -typesDir root = root codebasePath "types" -branchesDir root = root codebasePath "paths" -branchHeadDir root = branchesDir root "_head" -editsDir root = root codebasePath "patches" - -termDir, declDir :: CodebasePath -> Reference.Id -> FilePath -termDir root r = termsDir root componentIdToString r -declDir root r = typesDir root componentIdToString r - -referenceToDir :: Reference -> FilePath -referenceToDir r = case r of - Reference.Builtin name -> "_builtin" encodeFileName (Text.unpack name) - Reference.DerivedId hash -> componentIdToString hash - -dependentsDir', typeIndexDir', typeMentionsIndexDir' :: FilePath -> FilePath - -dependentsDir :: CodebasePath -> Reference -> FilePath -dependentsDir root r = dependentsDir' root referenceToDir r -dependentsDir' root = root codebasePath "dependents" - -watchesDir :: CodebasePath -> Text -> FilePath -watchesDir root WK.RegularWatch = - root codebasePath "watches" "_cache" -watchesDir root kind = - root codebasePath "watches" encodeFileName (Text.unpack kind) -watchPath :: CodebasePath -> WatchKind -> Reference.Id -> FilePath -watchPath root kind id = - watchesDir root (Text.pack kind) componentIdToString id <> ".ub" - -typeIndexDir :: CodebasePath -> Reference -> FilePath -typeIndexDir root r = typeIndexDir' root referenceToDir r -typeIndexDir' root = root codebasePath "type-index" - -typeMentionsIndexDir :: CodebasePath -> Reference -> FilePath -typeMentionsIndexDir root r = typeMentionsIndexDir' root referenceToDir r -typeMentionsIndexDir' root = root codebasePath "type-mentions-index" - -decodeFileName :: FilePath -> String -decodeFileName = let - go ('$':tl) = case span (/= '$') tl of - ("forward-slash", _:tl) -> '/' : go tl - ("back-slash", _:tl) -> '\\' : go tl - ("colon", _:tl) -> ':' : go tl - ("star", _:tl) -> '*' : go tl - ("question-mark", _:tl) -> '?' : go tl - ("double-quote", _:tl) -> '\"' : go tl - ("less-than", _:tl) -> '<' : go tl - ("greater-than", _:tl) -> '>' : go tl - ("pipe", _:tl) -> '|' : go tl - ('x':hex, _:tl) -> decodeHex hex ++ go tl - ("",_:tl) -> '$' : go tl - (s,_:tl) -> '$' : s ++ '$' : go tl -- unknown escapes left unchanged - (s,[]) -> s - go (hd:tl) = hd : go tl - go [] = [] - decodeHex :: String -> String - decodeHex s = either (const s) (Text.unpack . decodeUtf8) - . ByteString.decodeBase16 . encodeUtf8 . Text.pack $ s - in \case - "$dot$" -> "." - "$dotdot$" -> ".." - t -> go t - --- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os -encodeFileName :: String -> FilePath -encodeFileName = let - go ('/' : rem) = "$forward-slash$" <> go rem - go ('\\' : rem) = "$back-slash$" <> go rem - go (':' : rem) = "$colon$" <> go rem - go ('*' : rem) = "$star$" <> go rem - go ('?' : rem) = "$question-mark$" <> go rem - go ('"' : rem) = "$double-quote$" <> go rem - go ('<' : rem) = "$less-than$" <> go rem - go ('>' : rem) = "$greater-than$" <> go rem - go ('|' : rem) = "$pipe$" <> go rem - go ('$' : rem) = "$$" <> go rem - go (c : rem) | not (Char.isPrint c && Char.isAscii c) - = "$x" <> encodeHex [c] <> "$" <> go rem - | otherwise = c : go rem - go [] = [] - encodeHex :: String -> String - encodeHex = Text.unpack . Text.toUpper . ByteString.encodeBase16 . - encodeUtf8 . Text.pack - in \case - "." -> "$dot$" - ".." -> "$dotdot$" - t -> go t - -termPath, typePath, declPath :: CodebasePath -> Reference.Id -> FilePath -termPath path r = termDir path r "compiled.ub" -typePath path r = termDir path r "type.ub" -declPath path r = declDir path r "compiled.ub" - -branchPath :: CodebasePath -> Branch.Hash -> FilePath -branchPath root (RawHash h) = branchesDir root hashToString h ++ ".ub" - -editsPath :: CodebasePath -> Branch.EditHash -> FilePath -editsPath root h = editsDir root hashToString h ++ ".up" - -reflogPath :: CodebasePath -> FilePath -reflogPath root = root codebasePath "reflog" - -touchIdFile :: MonadIO m => Reference.Id -> FilePath -> m () -touchIdFile id fp = - touchFile (fp encodeFileName (componentIdToString id)) - -touchReferentFile :: MonadIO m => Referent -> FilePath -> m () -touchReferentFile id fp = - touchFile (fp encodeFileName (referentToString id)) - -touchReferentIdFile :: MonadIO m => Referent.Id -> FilePath -> m () -touchReferentIdFile = touchReferentFile . Referent.fromId - -touchFile :: MonadIO m => FilePath -> m () -touchFile fp = do - createDirectoryIfMissing True (takeDirectory fp) - writeBinaryFile fp mempty - --- checks if `path` looks like a unison codebase -minimalCodebaseStructure :: CodebasePath -> [FilePath] -minimalCodebaseStructure root = [ branchHeadDir root ] - --- checks if a minimal codebase structure exists at `path` -codebaseExists :: MonadIO m => CodebasePath -> m Bool -codebaseExists root = - and <$> traverse doesDirectoryExist (minimalCodebaseStructure root) - --- | load a branch w/ children from a FileCodebase -branchFromFiles :: MonadIO m => Branch.Cache m -> CodebasePath -> Branch.Hash -> m (Maybe (Branch m)) -branchFromFiles cache rootDir h = time "FileCodebase.Common.branchFromFiles" $ do - fileExists <- doesFileExist (branchPath rootDir h) - if fileExists then Just <$> - Branch.cachedRead - cache - (deserializeRawBranch rootDir) - (deserializeEdits rootDir) - h - else - pure Nothing - where - deserializeRawBranch - :: MonadIO m => CodebasePath -> Causal.Deserialize m Branch.Raw Branch.Raw - deserializeRawBranch root h = do - let ubf = branchPath root h - S.getFromFile' (V1.getCausal0 V1.getRawBranch) ubf >>= \case - Left err -> failWith $ InvalidBranchFile ubf err - Right c0 -> pure c0 - -deserializeEdits :: MonadIO m => CodebasePath -> Branch.EditHash -> m Patch -deserializeEdits root h = - let file = editsPath root h - in S.getFromFile' V1.getEdits file >>= \case - Left err -> failWith $ InvalidEditsFile file err - Right edits -> pure edits - -getPatch :: MonadIO m => CodebasePath -> Branch.EditHash -> m (Maybe Patch) -getPatch root h = - let file = editsPath root h - in S.getFromFile' V1.getEdits file >>= \case - Left _err -> pure Nothing - Right edits -> pure (Just edits) - -getRootBranch :: forall m. - MonadIO m => Branch.Cache m -> CodebasePath -> m (Either Codebase.GetRootBranchError (Branch m)) -getRootBranch cache root = time "FileCodebase.Common.getRootBranch" $ - ifM (codebaseExists root) - (listDirectory (branchHeadDir root) >>= filesToBranch) - (pure $ Left Codebase.NoRootBranch) - where - filesToBranch :: [FilePath] -> m (Either Codebase.GetRootBranchError (Branch m)) - filesToBranch = \case - [] -> pure $ Left Codebase.NoRootBranch - [single] -> runExceptT $ fileToBranch single - conflict -> runExceptT (traverse fileToBranch conflict) >>= \case - Right (x : xs) -> Right <$> foldM Branch.merge x xs - Right _ -> error "FileCodebase.getRootBranch.conflict can't be empty." - Left e -> Left <$> pure e - - fileToBranch :: String -> ExceptT Codebase.GetRootBranchError m (Branch m) - fileToBranch single = ExceptT $ case hashFromString single of - Nothing -> pure . Left $ Codebase.CouldntParseRootBranch single - Just (Branch.Hash -> h) -> branchFromFiles cache root h <&> - maybeToEither (Codebase.CouldntLoadRootBranch h) - -putRootBranch :: MonadIO m => CodebasePath -> Branch m -> m () -putRootBranch root b = do - putBranch root b - updateCausalHead (branchHeadDir root) (Branch._history b) - --- |only syncs branches and edits -- no dependencies -putBranch :: MonadIO m => CodebasePath -> Branch m -> m () -putBranch root b = - Branch.sync (hashExists root) - (serializeRawBranch root) - (serializeEdits root) - b - -hashExists :: MonadIO m => CodebasePath -> Branch.Hash -> m Bool -hashExists root h = doesFileExist (branchPath root h) - -serializeRawBranch - :: (MonadIO m) => CodebasePath -> Causal.Serialize m Branch.Raw Branch.Raw -serializeRawBranch root h = - S.putWithParentDirs (V1.putRawCausal V1.putRawBranch) (branchPath root h) - -patchExists :: MonadIO m => CodebasePath -> Branch.EditHash -> m Bool -patchExists root h = doesFileExist (editsPath root h) - -serializeEdits - :: MonadIO m => CodebasePath -> Branch.EditHash -> m Patch -> m () -serializeEdits root h medits = - unlessM (patchExists root h) $ do - edits <- medits - S.putWithParentDirs V1.putEdits (editsPath root h) edits - --- `headDir` is like ".unison/branches/head", or ".unison/edits/head"; --- not ".unison"; a little weird. I guess the reason this doesn't take --- the codebase root path is because it's applicable to any causal. --- We just have one though, and I suppose that won't change any time soon. -updateCausalHead :: MonadIO m => FilePath -> Causal n h e -> m () -updateCausalHead headDir c = do - let (RawHash h) = Causal.currentHash c - hs = hashToString h - -- write new head - touchFile (headDir hs) - -- delete existing heads - fmap (filter (/= hs)) (listDirectory headDir) - >>= traverse_ (removeFile . (headDir )) - --- here -hashFromString :: String -> Maybe Hash.Hash -hashFromString = Hash.fromBase32Hex . Text.pack - --- here -hashToString :: Hash.Hash -> String -hashToString = Hash.base32Hexs - -hashFromFilePath :: FilePath -> Maybe Hash.Hash -hashFromFilePath = hashFromString . takeBaseName - --- here -componentIdToString :: Reference.Id -> String -componentIdToString = Text.unpack . Reference.toText . Reference.DerivedId - --- here -componentIdFromString :: String -> Maybe Reference.Id -componentIdFromString = Reference.idFromText . Text.pack - --- here -referentFromString :: String -> Maybe Referent -referentFromString = Referent.fromText . Text.pack - -referentIdFromString :: String -> Maybe Referent.Id -referentIdFromString s = referentFromString s >>= \case - Referent.Ref (Reference.DerivedId r) -> Just $ Referent.Ref' r - Referent.Con (Reference.DerivedId r) i t -> Just $ Referent.Con' r i t - _ -> Nothing - --- here -referentToString :: Referent -> String -referentToString = Text.unpack . Referent.toText - -copyFileWithParents :: MonadIO m => FilePath -> FilePath -> m () -copyFileWithParents src dest = - unlessM (doesFileExist dest) $ do - createDirectoryIfMissing True (takeDirectory dest) - copyFile src dest - --- Use State and Lens to do some specified thing at most once, to create a file. -doFileOnce :: forall m s h. (MonadIO m, MonadState s m, Ord h) - => CodebasePath - -> SimpleLens s (Set h) -- lens to track if `h` is already done - -> (CodebasePath -> h -> FilePath) -- done if this filepath exists - -> (h -> m ()) -- do! - -> h -> m () -doFileOnce destPath l getFilename f h = - unlessM (use (l . to (Set.member h))) $ do - l %= Set.insert h - unlessM (doesFileExist (getFilename destPath h)) (f h) - -getTerm :: (MonadIO m, Ord v) => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (Term v a)) -getTerm getV getA path h = S.getFromFile (V1.getTerm getV getA) (termPath path h) - -getTypeOfTerm :: (MonadIO m, Ord v) => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (Type v a)) -getTypeOfTerm getV getA path h = S.getFromFile (V1.getType getV getA) (typePath path h) - -putTerm - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> Reference.Id - -> Term v a - -> Type v a - -> m () -putTerm putV putA path h e typ = do - let typeForIndexing = Type.removeAllEffectVars typ - rootTypeHash = Type.toReference typeForIndexing - typeMentions = Type.toReferenceMentions typeForIndexing - S.putWithParentDirs (V1.putTerm putV putA) (termPath path h) e - S.putWithParentDirs (V1.putType putV putA) (typePath path h) typ - -- Add the term as a dependent of its dependencies - let r = Referent.Ref (Reference.DerivedId h) - let deps = deleteComponent h $ Term.dependencies e <> Type.dependencies typ - traverse_ (touchIdFile h . dependentsDir path) deps - traverse_ (touchReferentFile r . typeMentionsIndexDir path) typeMentions - touchReferentFile r (typeIndexDir path rootTypeHash) - -getDecl :: (MonadIO m, Ord v) - => S.Get v -> S.Get a -> CodebasePath -> Reference.Id -> m (Maybe (DD.Decl v a)) -getDecl getV getA root h = - S.getFromFile - (V1.getEither - (V1.getEffectDeclaration getV getA) - (V1.getDataDeclaration getV getA)) - (declPath root h) - -putDecl - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> Reference.Id - -> DD.Decl v a - -> m () -putDecl putV putA path h decl = do - S.putWithParentDirs - (V1.putEither - (V1.putEffectDeclaration putV putA) - (V1.putDataDeclaration putV putA)) - (declPath path h) - decl - traverse_ (touchIdFile h . dependentsDir path) deps - traverse_ addCtorToTypeIndex ctors - where - deps = deleteComponent h . DD.dependencies $ either DD.toDataDecl id decl - r = Reference.DerivedId h - decl' = either DD.toDataDecl id decl - addCtorToTypeIndex (r, typ) = do - let rootHash = Type.toReference typ - typeMentions = Type.toReferenceMentions typ - touchReferentFile r (typeIndexDir path rootHash) - traverse_ (touchReferentFile r . typeMentionsIndexDir path) typeMentions - ct = DD.constructorType decl - ctors = - [ (Referent.Con r i ct, Type.removeAllEffectVars t) - | (t,i) <- DD.constructorTypes decl' `zip` [0..] ] - -getWatch :: (MonadIO m, Ord v) - => S.Get v - -> S.Get a - -> CodebasePath - -> WatchKind - -> Reference.Id - -> m (Maybe (Term v a)) -getWatch getV getA path k id = do - let wp = watchesDir path (Text.pack k) - createDirectoryIfMissing True wp - S.getFromFile (V1.getTerm getV getA) (wp componentIdToString id <> ".ub") - -putWatch - :: MonadIO m - => Var v - => S.Put v - -> S.Put a - -> CodebasePath - -> WatchKind - -> Reference.Id - -> Term v a - -> m () -putWatch putV putA root k id e = - S.putWithParentDirs - (V1.putTerm putV putA) - (watchPath root k id) - e - -loadReferencesByPrefix - :: MonadIO m => FilePath -> ShortHash -> m (Set Reference.Id) -loadReferencesByPrefix dir sh = do - refs <- mapMaybe Reference.fromShortHash - . filter (SH.isPrefixOf sh) - . mapMaybe SH.fromString - <$> listDirectory dir - pure $ Set.fromList [ i | Reference.DerivedId i <- refs] - -termReferencesByPrefix, typeReferencesByPrefix - :: MonadIO m => CodebasePath -> ShortHash -> m (Set Reference.Id) -termReferencesByPrefix root = loadReferencesByPrefix (termsDir root) -typeReferencesByPrefix root = loadReferencesByPrefix (typesDir root) - --- returns all the derived terms and derived constructors --- that have `sh` as a prefix -termReferentsByPrefix :: MonadIO m - => (CodebasePath -> Reference.Id -> m (Maybe (DD.Decl v a))) - -> CodebasePath - -> ShortHash - -> m (Set Referent.Id) -termReferentsByPrefix _ root sh@SH.Builtin{} = - Set.map Referent.Ref' <$> termReferencesByPrefix root sh - -- builtin types don't provide any referents we could match against, - -- only decl types do. Those get handled in the next case. -termReferentsByPrefix getDecl root sh@SH.ShortHash{} = do - terms <- termReferencesByPrefix root sh - ctors <- do - -- clear out any CID from the SH, so we can use it to find a type decl - types <- typeReferencesByPrefix root sh { SH.cid = Nothing } - foldMapM collectCtors types - pure (Set.map Referent.Ref' terms <> ctors) - where - -- load up the Decl for `ref` to see how many constructors it has, - -- and what constructor type - collectCtors ref = getDecl root ref <&> \case - Nothing -> mempty - Just decl -> - Set.fromList [ con - | i <- [0 .. ctorCount-1] - , let con = Referent.Con' ref i ct - , SH.isPrefixOf sh $ Referent.toShortHashId con] - where ct = either (const CT.Effect) (const CT.Data) decl - ctorCount = length . DD.constructors' $ DD.asDataDecl decl - -branchHashesByPrefix :: MonadIO m => CodebasePath -> ShortBranchHash -> m (Set Branch.Hash) -branchHashesByPrefix codebasePath p = - fmap (Set.fromList . join) . for [branchesDir] $ \f -> do - let dir = f codebasePath - paths <- filter (isPrefixOf . Text.unpack . SBH.toText $ p) <$> listDirectory dir - let refs = paths >>= (toList . filenameToHash) - pure refs - where - filenameToHash :: String -> Maybe Branch.Hash - filenameToHash f = case Text.splitOn "." $ Text.pack f of - [h, "ub"] -> Causal.RawHash <$> Hash.fromBase32Hex h - _ -> Nothing - -failWith :: MonadIO m => Err -> m a -failWith = liftIO . fail . show - --- | A version of listDirectory that returns mempty if the directory doesn't exist -listDirectory :: MonadIO m => FilePath -> m [FilePath] -listDirectory dir = liftIO $ - System.Directory.listDirectory dir `catch` (\(_ :: IOException) -> pure mempty) - --- | delete all the elements of a given reference component from a set -deleteComponent :: Reference.Id -> Set Reference -> Set Reference -deleteComponent r rs = Set.difference rs - (Reference.members . Reference.componentFor . Reference.DerivedId $ r) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs deleted file mode 100644 index d2735323e1..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/DataDeclaration.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# Language DeriveFoldable #-} -{-# Language DeriveTraversable #-} -{-# Language OverloadedStrings #-} -{-# Language PatternSynonyms #-} -{-# Language ViewPatterns #-} - -module Unison.Codebase.FileCodebase.DataDeclaration - ( DataDeclaration (..), - EffectDeclaration (..), - Decl, - Modifier(..), - asDataDecl, - constructorType, - constructorTypes, - declConstructorReferents, - declDependencies, - dependencies, - ) -where - -import Unison.Prelude - - -import qualified Data.Set as Set -import Prelude.Extras (Show1) -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import Unison.Codebase.FileCodebase.Type (Type) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.ConstructorType as CT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable -import qualified Unison.Referent' as Referent' -import Prelude hiding (cycle) - -type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) - -data DeclOrBuiltin v a = - Builtin CT.ConstructorType | Decl (Decl v a) - deriving (Eq, Show) - -asDataDecl :: Decl v a -> DataDeclaration v a -asDataDecl = either toDataDecl id - -declDependencies :: Ord v => Decl v a -> Set Reference -declDependencies = either (dependencies . toDataDecl) dependencies - -constructorType :: Decl v a -> CT.ConstructorType -constructorType = \case - Left{} -> CT.Effect - Right{} -> CT.Data - -data Modifier = Structural | Unique Text -- | Opaque (Set Reference) - deriving (Eq, Ord, Show) - -data DataDeclaration v a = DataDeclaration { - modifier :: Modifier, - annotation :: a, - bound :: [v], - constructors' :: [(a, v, Type v a)] -} deriving (Eq, Show, Functor) - -newtype EffectDeclaration v a = EffectDeclaration { - toDataDecl :: DataDeclaration v a -} deriving (Eq,Show,Functor) - -constructorTypes :: DataDeclaration v a -> [Type v a] -constructorTypes = (snd <$>) . constructors - -constructors :: DataDeclaration v a -> [(v, Type v a)] -constructors (DataDeclaration _ _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] - --- This function is unsound, since the `rid` and the `decl` have to match. --- It should probably be hashed directly from the Decl, once we have a --- reliable way of doing that. —AI -declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] -declConstructorReferents rid decl = - [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] - where ct = constructorType decl - -constructorIds :: DataDeclaration v a -> [Int] -constructorIds dd = [0 .. length (constructors dd) - 1] - - -dependencies :: Ord v => DataDeclaration v a -> Set Reference -dependencies dd = - Set.unions (Type.dependencies <$> constructorTypes dd) - -data F a - = Type (Type.F a) - | LetRec [a] a - | Constructors [a] - | Modified Modifier a - deriving (Functor, Foldable, Show, Show1) - -instance Hashable1 F where - hash1 hashCycle hash e = - let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `2` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 2 : case e of - Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] - LetRec bindings body -> - let (hashes, hash') = hashCycle bindings - in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] - Constructors cs -> - let (hashes, _) = hashCycle cs - in tag 2 : map hashed hashes - Modified m t -> - [tag 3, Hashable.accumulateToken m, hashed $ hash t] - -instance Hashable.Hashable Modifier where - tokens Structural = [Hashable.Tag 0] - tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs deleted file mode 100644 index 6d8f591d32..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Init.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE OverloadedStrings #-} - -module Unison.Codebase.FileCodebase.Init (Init(..), CreateCodebaseError(..), Pretty) where - -import Unison.Codebase.FileCodebase.Codebase (Codebase) -import Unison.CodebasePath (CodebasePath) -import qualified Unison.Util.Pretty as P - -type Pretty = P.Pretty P.ColorText - -data CreateCodebaseError - = CreateCodebaseAlreadyExists - | CreateCodebaseOther Pretty - -type DebugName = String - -data Init m v a = Init - { -- | open an existing codebase - openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), - -- | create a new codebase - createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), - -- | given a codebase root, and given that the codebase root may have other junk in it, - -- give the path to the "actual" files; e.g. what a forked transcript should clone. - codebasePath :: CodebasePath -> CodebasePath - } - diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs deleted file mode 100644 index 76c23337ec..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/LabeledDependency.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Codebase.FileCodebase.LabeledDependency - ( derivedTerm - , derivedType - , termRef - , typeRef - , referent - , dataConstructor - , effectConstructor - , fold - , referents - , toReference - , LabeledDependency - , partition - ) where - -import Unison.Prelude hiding (fold) - -import qualified Data.Set as Set -import Unison.Codebase.FileCodebase.Reference (Id, Reference (DerivedId)) -import Unison.Codebase.FileCodebase.Referent (ConstructorId, Referent, pattern Con, pattern Ref) -import Unison.ConstructorType (ConstructorType (Data, Effect)) - --- dumb constructor name is private -newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) - -derivedType, derivedTerm :: Id -> LabeledDependency -typeRef, termRef :: Reference -> LabeledDependency -referent :: Referent -> LabeledDependency -dataConstructor :: Reference -> ConstructorId -> LabeledDependency -effectConstructor :: Reference -> ConstructorId -> LabeledDependency - -derivedType = X . Left . DerivedId -derivedTerm = X . Right . Ref . DerivedId -typeRef = X . Left -termRef = X . Right . Ref -referent = X . Right -dataConstructor r cid = X . Right $ Con r cid Data -effectConstructor r cid = X . Right $ Con r cid Effect - -referents :: Foldable f => f Referent -> Set LabeledDependency -referents rs = Set.fromList (map referent $ toList rs) - -fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a -fold f g (X e) = either f g e - -partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) -partition = partitionEithers . map (\(X e) -> e) . toList - --- | Left TypeRef | Right TermRef -toReference :: LabeledDependency -> Either Reference Reference -toReference = \case - X (Left r) -> Left r - X (Right (Ref r)) -> Right r - X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs deleted file mode 100644 index e6a58eb01a..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Metadata.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Unison.Codebase.FileCodebase.Metadata where - -import Unison.Prelude - -import qualified Data.Map as Map -import qualified Data.Set as Set -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Util.List as List -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as R -import qualified Unison.Util.Relation3 as R3 -import Unison.Util.Relation4 (Relation4) -import qualified Unison.Util.Relation4 as R4 -import Unison.Util.Star3 (Star3) -import qualified Unison.Util.Star3 as Star3 - -type Type = Reference -type Value = Reference - --- keys can be terms or types -type Metadata = Map Type (Set Value) - --- `a` is generally the type of references or hashes --- `n` is generally the the type of name associated with the references --- `Type` is the type of metadata. Duplicate info to speed up certain queries. --- `(Type, Value)` is the metadata value itself along with its type. -type Star a n = Star3 a n Type (Type, Value) -type R4 a n = R4.Relation4 a n Type Value - -starToR4 :: (Ord r, Ord n) => Star r n -> Relation4 r n Type Value -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 -> R4 a n -> Bool -hasMetadataWithType' a t r = - fromMaybe False $ Set.member t . R3.d2s <$> (Map.lookup a $ R4.d1 r) - -hasMetadataWithType :: Ord a => a -> Type -> Star a n -> Bool -hasMetadataWithType a t = Set.member t . R.lookupDom a . Star3.d2 - -inserts :: (Ord a, Ord n) => [(a, Type, Value)] -> Star a n -> Star a n -inserts tups s = foldl' (flip insert) s tups - -insertWithMetadata - :: (Ord a, Ord n) => (a, Metadata) -> Star a n -> Star a n -insertWithMetadata (a, md) = - inserts [ (a, ty, v) | (ty, vs) <- Map.toList md, v <- toList vs ] - -insert :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n -insert (a, ty, v) = Star3.insertD23 (a, ty, (ty,v)) - -delete :: (Ord a, Ord n) => (a, Type, Value) -> Star a n -> Star a n -delete (a, ty, v) s = let - s' = Star3.deleteD3 (a, (ty,v)) s - -- if (ty,v) is the last metadata of type ty - -- we also delete (a, ty) from the d2 index - metadataByType = List.multimap (toList (R.lookupDom a (Star3.d3 s))) - in - case Map.lookup ty metadataByType of - Just vs | all (== v) vs -> Star3.deleteD2 (a, ty) s' - _ -> s' - --- parallel composition - commutative and associative -merge :: Metadata -> Metadata -> Metadata -merge = Map.unionWith (<>) - --- sequential composition, right-biased -append :: Metadata -> Metadata -> Metadata -append = Map.unionWith (flip const) - -empty :: Metadata -empty = mempty - -singleton :: Type -> Value -> Metadata -singleton ty v = Map.singleton ty (Set.singleton v) - -toRelation :: Star3 a n x y -> Relation a n -toRelation = Star3.d1 diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs deleted file mode 100644 index 131be69311..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Patch.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.FileCodebase.Patch where - -import Unison.Prelude hiding (empty) - -import Prelude hiding (head,read,subtract) - -import Control.Lens hiding (children, cons, transform) -import qualified Data.Set as Set -import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) -import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD -import Unison.Codebase.FileCodebase.Reference (Reference) -import Unison.Codebase.FileCodebase.TermEdit (TermEdit, Typing (Same)) -import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit -import Unison.Codebase.FileCodebase.TypeEdit (TypeEdit) -import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as R - -data Patch = Patch - { _termEdits :: Relation Reference TermEdit - , _typeEdits :: Relation Reference TypeEdit - } deriving (Eq, Ord, Show) - -data PatchDiff = PatchDiff - { _addedTermEdits :: Relation Reference TermEdit - , _addedTypeEdits :: Relation Reference TypeEdit - , _removedTermEdits :: Relation Reference TermEdit - , _removedTypeEdits :: Relation Reference TypeEdit - } deriving (Eq, Ord, Show) - -makeLenses ''Patch -makeLenses ''PatchDiff - -diff :: Patch -> Patch -> PatchDiff -diff new old = PatchDiff - { _addedTermEdits = R.difference (view termEdits new) (view termEdits old) - , _addedTypeEdits = R.difference (view typeEdits new) (view typeEdits old) - , _removedTypeEdits = R.difference (view typeEdits old) (view typeEdits new) - , _removedTermEdits = R.difference (view termEdits old) (view termEdits new) - } - -labeledDependencies :: Patch -> Set LabeledDependency -labeledDependencies Patch {..} = - Set.map LD.termRef (R.dom _termEdits) - <> Set.fromList - (fmap LD.termRef $ TermEdit.references =<< toList (R.ran _termEdits)) - <> Set.map LD.typeRef (R.dom _typeEdits) - <> Set.fromList - (fmap LD.typeRef $ TypeEdit.references =<< toList (R.ran _typeEdits)) - -empty :: Patch -empty = Patch mempty mempty - -isEmpty :: Patch -> Bool -isEmpty p = p == empty - -allReferences :: Patch -> Set Reference -allReferences p = typeReferences p <> termReferences p where - typeReferences p = Set.fromList - [ r | (old, TypeEdit.Replace new) <- R.toList (_typeEdits p) - , r <- [old, new] ] - termReferences p = Set.fromList - [ r | (old, TermEdit.Replace new _) <- R.toList (_termEdits p) - , r <- [old, new] ] - --- | Returns the set of references which are the target of an arrow in the patch -allReferenceTargets :: Patch -> Set Reference -allReferenceTargets p = typeReferences p <> termReferences p where - typeReferences p = Set.fromList - [ new | (_, TypeEdit.Replace new) <- R.toList (_typeEdits p) ] - termReferences p = Set.fromList - [ new | (_, TermEdit.Replace new _) <- R.toList (_termEdits p) ] - -updateTerm :: (Reference -> Reference -> Typing) - -> Reference -> TermEdit -> Patch -> Patch -updateTerm typing r edit p = - -- get D ~= lookupRan r - -- for each d ∈ D, remove (d, r) and add (d, r') - -- add (r, r') and remove (r', r') - let deleteCycle = case edit of - TermEdit.Deprecate -> id - TermEdit.Replace r' _ -> R.delete r' (TermEdit.Replace r' Same) - edits' :: Relation Reference TermEdit - edits' = deleteCycle . R.insert r edit . R.map f $ _termEdits p - f (x, TermEdit.Replace y _) | y == r = case edit of - TermEdit.Replace r' _ -> (x, TermEdit.Replace r' (typing x r')) - TermEdit.Deprecate -> (x, TermEdit.Deprecate) - f p = p - in p { _termEdits = edits' } - -updateType :: Reference -> TypeEdit -> Patch -> Patch -updateType r edit p = - let deleteCycle = case edit of - TypeEdit.Deprecate -> id - TypeEdit.Replace r' -> R.delete r' (TypeEdit.Replace r') - edits' :: Relation Reference TypeEdit - edits' = deleteCycle . R.insert r edit . R.map f $ _typeEdits p - f (x, TypeEdit.Replace y) | y == r = case edit of - TypeEdit.Replace r' -> (x, TypeEdit.Replace r') - TypeEdit.Deprecate -> (x, TypeEdit.Deprecate) - f p = p - in p { _typeEdits = edits' } - -conflicts :: Patch -> Patch -conflicts Patch{..} = - Patch (R.filterManyDom _termEdits) (R.filterManyDom _typeEdits) - -instance Semigroup Patch where - a <> b = Patch (_termEdits a <> _termEdits b) - (_typeEdits a <> _typeEdits b) - -instance Monoid Patch where - mappend = (<>) - mempty = Patch mempty mempty - -instance Hashable Patch where - tokens e = [ H.Hashed (H.accumulate (H.tokens (_termEdits e))), - H.Hashed (H.accumulate (H.tokens (_typeEdits e))) ] - -instance Semigroup PatchDiff where - a <> b = PatchDiff - { _addedTermEdits = _addedTermEdits a <> _addedTermEdits b - , _addedTypeEdits = _addedTypeEdits a <> _addedTypeEdits b - , _removedTermEdits = _removedTermEdits a <> _removedTermEdits b - , _removedTypeEdits = _removedTypeEdits a <> _removedTypeEdits b - } - -instance Monoid PatchDiff where - mappend = (<>) - mempty = PatchDiff mempty mempty mempty mempty diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs deleted file mode 100644 index c25a42250c..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Pattern.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} - -module Unison.Codebase.FileCodebase.Pattern where - -import Unison.Prelude - -import Data.Foldable as Foldable hiding (foldMap') -import Data.List (intercalate) -import qualified Data.Set as Set -import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) -import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.Hashable as H - -type ConstructorId = Int - -data Pattern loc - = Unbound loc - | Var loc - | Boolean loc !Bool - | Int loc !Int64 - | Nat loc !Word64 - | Float loc !Double - | Text loc !Text - | Char loc !Char - | Constructor loc !Reference !Int [Pattern loc] - | As loc (Pattern loc) - | EffectPure loc (Pattern loc) - | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) - | SequenceLiteral loc [Pattern loc] - | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) - deriving (Ord,Generic,Functor,Foldable,Traversable) - -data SeqOp = Cons - | Snoc - | Concat - deriving (Eq, Show, Ord, Generic) - -instance H.Hashable SeqOp where - tokens Cons = [H.Tag 0] - tokens Snoc = [H.Tag 1] - tokens Concat = [H.Tag 2] - -instance Show (Pattern loc) where - show (Unbound _ ) = "Unbound" - show (Var _ ) = "Var" - show (Boolean _ x) = "Boolean " <> show x - show (Int _ x) = "Int " <> show x - show (Nat _ x) = "Nat " <> show x - show (Float _ x) = "Float " <> show x - show (Text _ t) = "Text " <> show t - show (Char _ c) = "Char " <> show c - show (Constructor _ r i ps) = - "Constructor " <> unwords [show r, show i, show ps] - show (As _ p) = "As " <> show p - show (EffectPure _ k) = "EffectPure " <> show k - show (EffectBind _ r i ps k) = - "EffectBind " <> unwords [show r, show i, show ps, show k] - show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) - show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt - -application :: Pattern loc -> Bool -application (Constructor _ _ _ (_ : _)) = True -application _ = False - -loc :: Pattern loc -> loc -loc p = head $ Foldable.toList p - -setLoc :: Pattern loc -> loc -> Pattern loc -setLoc p loc = case p of - EffectBind _ a b c d -> EffectBind loc a b c d - EffectPure _ a -> EffectPure loc a - As _ a -> As loc a - Constructor _ a b c -> Constructor loc a b c - SequenceLiteral _ ps -> SequenceLiteral loc ps - SequenceOp _ ph op pt -> SequenceOp loc ph op pt - x -> fmap (const loc) x - -instance H.Hashable (Pattern p) where - tokens (Unbound _) = [H.Tag 0] - tokens (Var _) = [H.Tag 1] - tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] - tokens (Int _ n) = H.Tag 3 : [H.Int n] - tokens (Nat _ n) = H.Tag 4 : [H.Nat n] - tokens (Float _ f) = H.Tag 5 : H.tokens f - tokens (Constructor _ r n args) = - [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] - tokens (EffectPure _ p) = H.Tag 7 : H.tokens p - tokens (EffectBind _ r n args k) = - [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] - tokens (As _ p) = H.Tag 9 : H.tokens p - tokens (Text _ t) = H.Tag 10 : H.tokens t - tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps - tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r - tokens (Char _ c) = H.Tag 13 : H.tokens c - -instance Eq (Pattern loc) where - Unbound _ == Unbound _ = True - Var _ == Var _ = True - Boolean _ b == Boolean _ b2 = b == b2 - Int _ n == Int _ m = n == m - Nat _ n == Nat _ m = n == m - Float _ f == Float _ g = f == g - Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs - EffectPure _ p == EffectPure _ q = p == q - EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 - As _ p == As _ q = p == q - Text _ t == Text _ t2 = t == t2 - SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 - SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 - _ == _ = False - -foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m -foldMap' f p = case p of - Unbound _ -> f p - Var _ -> f p - Boolean _ _ -> f p - Int _ _ -> f p - Nat _ _ -> f p - Float _ _ -> f p - Text _ _ -> f p - Char _ _ -> f p - Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps - As _ p' -> f p <> foldMap' f p' - EffectPure _ p' -> f p <> foldMap' f p' - EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' - SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps - SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 - -generalizedDependencies - :: Ord r - => (Reference -> r) - -> (Reference -> ConstructorId -> r) - -> (Reference -> r) - -> (Reference -> ConstructorId -> r) - -> (Reference -> r) - -> Pattern loc - -> Set r -generalizedDependencies literalType dataConstructor dataType effectConstructor effectType - = Set.fromList . foldMap' - (\case - Unbound _ -> mempty - Var _ -> mempty - As _ _ -> mempty - Constructor _ r cid _ -> [dataType r, dataConstructor r cid] - EffectPure _ _ -> [effectType Type.effectRef] - EffectBind _ r cid _ _ -> - [effectType Type.effectRef, effectType r, effectConstructor r cid] - SequenceLiteral _ _ -> [literalType Type.listRef] - SequenceOp {} -> [literalType Type.listRef] - Boolean _ _ -> [literalType Type.booleanRef] - Int _ _ -> [literalType Type.intRef] - Nat _ _ -> [literalType Type.natRef] - Float _ _ -> [literalType Type.floatRef] - Text _ _ -> [literalType Type.textRef] - Char _ _ -> [literalType Type.charRef] - ) - -labeledDependencies :: Pattern loc -> Set LabeledDependency -labeledDependencies = generalizedDependencies LD.typeRef - LD.dataConstructor - LD.typeRef - LD.effectConstructor - LD.typeRef diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs deleted file mode 100644 index a3c44cfccb..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Reference - (Reference, - pattern Builtin, - pattern Derived, - pattern DerivedId, - Id(..), - Pos, - Size, - derivedBase32Hex, - Component, members, - components, - groupByComponent, - componentFor, - unsafeFromText, - idFromText, - isPrefixOf, - fromShortHash, - fromText, - readSuffix, - showShort, - showSuffix, - toId, - toText, - unsafeId, - toShortHash, - idToShortHash) where - -import Unison.Prelude - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Unison.Hash as H -import Unison.Hashable as Hashable -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import Data.Char (isDigit) - --- | Either a builtin or a user defined (hashed) top-level declaration. --- --- Used for both terms and types. Doesn't distinguish between them. --- --- Other used defined things like local variables don't get @Reference@s. -data Reference - = Builtin Text.Text - -- `Derived` can be part of a strongly connected component. - -- The `Pos` refers to a particular element of the component - -- and the `Size` is the number of elements in the component. - -- Using an ugly name so no one tempted to use this - | DerivedId Id deriving (Eq,Ord,Generic) - -pattern Derived :: H.Hash -> Pos -> Size -> Reference -pattern Derived h i n = DerivedId (Id h i n) - -{-# COMPLETE Builtin, Derived #-} - --- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. -data Id = Id H.Hash Pos Size deriving (Generic) - -unsafeId :: Reference -> Id -unsafeId (Builtin b) = - error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." -unsafeId (DerivedId x) = x - -idToShortHash :: Id -> ShortHash -idToShortHash = toShortHash . DerivedId - --- todo: move these to ShortHash module? --- but Show Reference currently depends on SH -toShortHash :: Reference -> ShortHash -toShortHash (Builtin b) = SH.Builtin b -toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing -toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing - where - -- todo: remove `n` parameter; must also update readSuffix - index = Just $ showSuffix i n - --- toShortHash . fromJust . fromShortHash == id and --- fromJust . fromShortHash . toShortHash == id --- but for arbitrary ShortHashes which may be broken at the wrong boundary, it --- may not be possible to base32Hex decode them. These will return Nothing. --- Also, ShortHashes that include constructor ids will return Nothing; --- try Referent.fromShortHash -fromShortHash :: ShortHash -> Maybe Reference -fromShortHash (SH.Builtin b) = Just (Builtin b) -fromShortHash (SH.ShortHash prefix cycle Nothing) = do - h <- H.fromBase32Hex prefix - case cycle of - Nothing -> Just (Derived h 0 1) - Just t -> case Text.splitOn "c" t of - [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) - _ -> Nothing -fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing - --- (3,10) encoded as "3c10" --- (0,93) encoded as "0c93" -showSuffix :: Pos -> Size -> Text -showSuffix i n = Text.pack $ show i <> "c" <> show n - --- todo: don't read or return size; must also update showSuffix and fromText -readSuffix :: Text -> Either String (Pos, Size) -readSuffix t = case Text.breakOn "c" t of - (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> - Right (read (Text.unpack pos), read (Text.unpack size)) - _ -> Left "suffix decoding error" - -isPrefixOf :: ShortHash -> Reference -> Bool -isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) - -toText :: Reference -> Text -toText = SH.toText . toShortHash - -showShort :: Int -> Reference -> Text -showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash - -type Pos = Word64 -type Size = Word64 - -newtype Component = Component { members :: Set Reference } - --- Gives the component (dependency cycle) that the reference is a part of -componentFor :: Reference -> Component -componentFor b@Builtin {} = Component (Set.singleton b) -componentFor (Derived h _ n) = - Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] - -derivedBase32Hex :: Text -> Pos -> Size -> Reference -derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) - where - msg = error $ "Reference.derivedBase32Hex " <> show h - h = H.fromBase32Hex b32Hex - -unsafeFromText :: Text -> Reference -unsafeFromText = either error id . fromText - -idFromText :: Text -> Maybe Id -idFromText s = case fromText s of - Left _ -> Nothing - Right (Builtin _) -> Nothing - Right (DerivedId id) -> pure id - -toId :: Reference -> Maybe Id -toId (DerivedId id) = Just id -toId Builtin{} = Nothing - --- examples: --- `##Text.take` — builtins don’t have cycles --- `#2tWjVAuc7` — derived, no cycle --- `#y9ycWkiC1.y9` — derived, part of cycle --- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. -fromText :: Text -> Either String Reference -fromText t = case Text.split (=='#') t of - [_, "", b] -> Right (Builtin b) - [_, h] -> case Text.split (=='.') h of - [hash] -> Right (derivedBase32Hex hash 0 1) - [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix - _ -> bail - _ -> bail - where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t - -component :: H.Hash -> [k] -> [(k, Id)] -component h ks = let - size = fromIntegral (length ks) - in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] - -components :: [(H.Hash, [k])] -> [(k, Id)] -components sccs = uncurry component =<< sccs - -groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] -groupByComponent refs = done $ foldl' insert Map.empty refs - where - insert m (k, r@(Derived h _ _)) = - Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) - insert m (k, r) = - Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) - done m = sortOn snd <$> toList m - -instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId -instance Show Reference where show = SH.toString . SH.take 5 . toShortHash - -instance Hashable.Hashable Reference where - tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] - tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] - --- | Two references mustn't differ in cycle length only. -instance Eq Id where x == y = compare x y == EQ -instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs deleted file mode 100644 index 8a00aa385c..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Reference/Util.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Unison.Codebase.FileCodebase.Reference.Util where - -import Unison.Prelude - -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import Unison.Hashable (Hashable1) -import Unison.ABT (Var) -import qualified Unison.ABT as ABT -import qualified Data.Map as Map - -hashComponents :: - (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) - => (Reference.Id -> ABT.Term f v ()) - -> Map v (ABT.Term f v a) - -> Map v (Reference.Id, ABT.Term f v a) -hashComponents embedRef tms = - Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] - where cs = Reference.components $ ABT.hashComponents ref tms - ref h i n = embedRef (Reference.Id h i n) - - diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs deleted file mode 100644 index a022d3b4a5..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Referent.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - -module Unison.Codebase.FileCodebase.Referent where - -import Unison.Prelude -import Unison.Referent' ( Referent'(..), toReference' ) - -import qualified Data.Char as Char -import qualified Data.Text as Text -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as R -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH - -import Unison.ConstructorType (ConstructorType) -import qualified Unison.ConstructorType as CT - --- | Specifies a term. --- --- Either a term 'Reference', a data constructor, or an effect constructor. --- --- Slightly odd naming. This is the "referent of term name in the codebase", --- rather than the target of a Reference. -type Referent = Referent' Reference -type ConstructorId = Int -pattern Ref :: Reference -> Referent -pattern Ref r = Ref' r -pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent -pattern Con r i t = Con' r i t -{-# COMPLETE Ref, Con #-} - --- | Cannot be a builtin. -type Id = Referent' R.Id - --- referentToTerm moved to Term.fromReferent --- termToReferent moved to Term.toReferent - --- todo: move these to ShortHash module -toShortHash :: Referent -> ShortHash -toShortHash = \case - Ref r -> R.toShortHash r - Con r i _ -> patternShortHash r i - -toShortHashId :: Id -> ShortHash -toShortHashId = toShortHash . fromId - --- also used by HashQualified.fromPattern -patternShortHash :: Reference -> ConstructorId -> ShortHash -patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } - -showShort :: Int -> Referent -> Text -showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash - -toText :: Referent -> Text -toText = \case - Ref r -> R.toText r - Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) - -ctorTypeText :: CT.ConstructorType -> Text -ctorTypeText CT.Effect = EffectCtor -ctorTypeText CT.Data = DataCtor - -pattern EffectCtor = "a" -pattern DataCtor = "d" - -toString :: Referent -> String -toString = Text.unpack . toText - -isConstructor :: Referent -> Bool -isConstructor Con{} = True -isConstructor _ = False - -toTermReference :: Referent -> Maybe Reference -toTermReference = \case - Ref r -> Just r - _ -> Nothing - -toReference :: Referent -> Reference -toReference = toReference' - -fromId :: Id -> Referent -fromId = fmap R.DerivedId - -toTypeReference :: Referent -> Maybe Reference -toTypeReference = \case - Con r _i _t -> Just r - _ -> Nothing - -isPrefixOf :: ShortHash -> Referent -> Bool -isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) - -unsafeFromText :: Text -> Referent -unsafeFromText = fromMaybe (error "invalid referent") . fromText - --- #abc[.xy][#cid] -fromText :: Text -> Maybe Referent -fromText t = either (const Nothing) Just $ - -- if the string has just one hash at the start, it's just a reference - if Text.length refPart == 1 then - Ref <$> R.fromText t - else if Text.all Char.isDigit cidPart then do - r <- R.fromText (Text.dropEnd 1 refPart) - ctorType <- ctorType - let cid = read (Text.unpack cidPart) - pure $ Con r cid ctorType - else - Left ("invalid constructor id: " <> Text.unpack cidPart) - where - ctorType = case Text.take 1 cidPart' of - EffectCtor -> Right CT.Effect - DataCtor -> Right CT.Data - _otherwise -> - Left ("invalid constructor type (expected '" - <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') - refPart = Text.dropWhileEnd (/= '#') t - cidPart' = Text.takeWhileEnd (/= '#') t - cidPart = Text.drop 1 cidPart' - -fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a -fold fr fc = \case - Ref' r -> fr r - Con' r i ct -> fc r i ct - diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs deleted file mode 100644 index d4b33ad9c4..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Serialization/V1.hs +++ /dev/null @@ -1,790 +0,0 @@ -{-# LANGUAGE Strict #-} -{-# LANGUAGE RankNTypes #-} - -module Unison.Codebase.FileCodebase.Serialization.V1 - ( formatSymbol, - getBranchDependencies, - getCausal0, - getRawBranch, - getEdits, - putRawCausal, - putRawBranch, - putEdits, - getTerm, - getType, - putTerm, - putType, - getEither, - getEffectDeclaration, - getDataDeclaration, - putEither, - putEffectDeclaration, - putDataDeclaration, - ) -where - -import Unison.Prelude - -import Prelude hiding (getChar, putChar) - -import Data.Bits (Bits) -import qualified Data.ByteString as B -import Data.Bytes.Get as Ser -import Data.Bytes.Put as Ser -import Data.Bytes.Serial (deserialize, deserializeBE, serialize, serializeBE) -import Data.Bytes.Signed (Unsigned) -import Data.Bytes.VarInt (VarInt (..)) -import Data.List (elemIndex) -import qualified Data.Map as Map -import qualified Data.Sequence as Sequence -import qualified Data.Set as Set -import qualified Unison.ABT as ABT -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import Unison.Codebase.Causal (Raw (..), RawHash (..), unRawHash) -import qualified Unison.Codebase.Causal as Causal -import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import Unison.Codebase.FileCodebase.Referent (Referent) -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import Unison.Codebase.FileCodebase.Term (Term) -import qualified Unison.Codebase.FileCodebase.Term as Term -import Unison.Codebase.FileCodebase.Type (Type) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.Codebase.FileCodebase.Metadata as Metadata -import Unison.Codebase.FileCodebase.Patch (Patch (..)) -import qualified Unison.Codebase.FileCodebase.Patch as Patch -import qualified Unison.Codebase.Serialization as S -import Unison.Codebase.FileCodebase.TermEdit (TermEdit) -import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit -import Unison.Codebase.FileCodebase.TypeEdit (TypeEdit) -import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit -import qualified Unison.ConstructorType as CT -import Unison.Codebase.FileCodebase.DataDeclaration (DataDeclaration, EffectDeclaration) -import qualified Unison.Codebase.FileCodebase.DataDeclaration as DataDeclaration -import Unison.Hash (Hash) -import qualified Unison.Hash as Hash -import Unison.Kind (Kind) -import qualified Unison.Kind as Kind -import Unison.NameSegment (NameSegment (NameSegment)) -import qualified Unison.NameSegment as NameSegment -import Unison.Codebase.FileCodebase.Pattern (Pattern, SeqOp) -import qualified Unison.Codebase.FileCodebase.Pattern as Pattern -import Unison.Symbol (Symbol (..)) -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as Relation -import Unison.Util.Star3 (Star3) -import qualified Unison.Util.Star3 as Star3 -import qualified Unison.Var as Var - --- ABOUT THIS FORMAT: --- --- A serialization format for uncompiled Unison syntax trees. --- --- Finalized: No --- --- If Finalized: Yes, don't modify this file in a way that affects serialized form. --- Instead, create a new file, V(n + 1). --- This ensures that we have a well-defined serialized form and can read --- and write old versions. - -unknownTag :: (MonadGet m, Show a) => String -> a -> m x -unknownTag msg tag = - fail $ "unknown tag " ++ show tag ++ - " while deserializing: " ++ msg - -putRawCausal :: MonadPut m => (a -> m ()) -> Causal.Raw h a -> m () -putRawCausal putA = \case - RawOne a -> putWord8 0 >> putA a - RawCons a t -> putWord8 1 >> (putHash . unRawHash) t >> putA a - RawMerge a ts -> - putWord8 2 >> putFoldable (putHash . unRawHash) ts >> putA a - -getCausal0 :: MonadGet m => m a -> m (Causal.Raw h a) -getCausal0 getA = getWord8 >>= \case - 0 -> RawOne <$> getA - 1 -> flip RawCons <$> (RawHash <$> getHash) <*> getA - 2 -> flip RawMerge . Set.fromList <$> getList (RawHash <$> getHash) <*> getA - x -> unknownTag "Causal0" x - --- Like getCausal, but doesn't bother to read the actual value in the causal, --- it just reads the hashes. Useful for more efficient implementation of --- `Causal.before`. --- getCausal00 :: MonadGet m => m Causal00 --- getCausal00 = getWord8 >>= \case --- 0 -> pure One00 --- 1 -> Cons00 <$> getHash --- 2 -> Merge00 . Set.fromList <$> getList getHash - --- 1. Can no longer read a causal using just MonadGet; --- need a way to construct the loader that forms its tail. --- Same problem with loading Branch0 with monadic tails. --- 2. Without the monadic tail, need external info to know how to --- load the tail. When modifying a nested structure, we --- need a way to save the intermediate nodes. (e.g. zipper?) --- 3. We ran into trouble trying to intermingle the marshalling monad --- (put/get) with the loading/saving monad (io). --- 4. PutT was weird because we don't think we want the Codebase monad to --- randomly be able to accumulate bytestrings (put) that don't even reset. --- 5. We could specialize `Causal m e` to a particular monad that tries to do --- the right things wrt caching? --- putCausal0 :: MonadPut m => Causal a -> (a -> m ()) -> m () --- putCausal0 = undefined - --- This loads the tail in order to write it? --- May be crucial to do so, if "loading" tail from `pure`, but --- otherwise weird. We'd like to skip writing the tail if it already --- exists, but how can we tell? --- Also, we're not even supposed to be writing the tail into the same buffer --- as head. We should be writing the hash of the tail though, so we can --- know which file we need to load it from; loading another file is also --- something we can't do in this model. ----- --- putCausal :: (MonadPut m, Monad n) => Causal n a -> (a -> m ()) -> n (m ()) --- putCausal (Causal.One hash a) putA = --- pure $ putWord8 1 *> putHash hash *> putA a --- putCausal (Causal.ConsN m) putA = do --- (conss, tail) <- m --- pure (putWord8 2 *> putFoldable conss (putPair' putHash putA)) --- *> putCausal tail putA --- putCausal (Causal.Merge hash a tails) putA = do --- pure (putWord8 3 *> putHash hash *> putA a) --- putFoldableN (Map.toList tails) $ putPair'' putHash (>>= (`putCausal` putA)) --- putCausal (Causal.Cons _ _ _) _ = --- error "deserializing 'Causal': the ConsN pattern should have matched here!" - - --- getCausal :: MonadGet m => m a -> m (Causal a) --- getCausal getA = getWord8 >>= \case --- 1 -> Causal.One <$> getHash <*> getA --- 2 -> Causal.consN <$> getList (getPair getHash getA) <*> getCausal getA --- 3 -> Causal.Merge <$> getHash <*> getA <*> --- (Map.fromList <$> getList (getPair getHash $ getCausal getA)) --- x -> unknownTag "causal" x - --- getCausal :: - -putLength :: - (MonadPut m, Integral n, Integral (Unsigned n), - Bits n, Bits (Unsigned n)) - => n -> m () -putLength = serialize . VarInt - -getLength :: - (MonadGet m, Integral n, Integral (Unsigned n), - Bits n, Bits (Unsigned n)) - => m n -getLength = unVarInt <$> deserialize - -putText :: MonadPut m => Text -> m () -putText text = do - let bs = encodeUtf8 text - putLength $ B.length bs - putByteString bs - -getText :: MonadGet m => m Text -getText = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ decodeUtf8 bs - -skipText :: MonadGet m => m () -skipText = do - len <- getLength - void $ Ser.getBytes len - -putFloat :: MonadPut m => Double -> m () -putFloat = serializeBE - -getFloat :: MonadGet m => m Double -getFloat = deserializeBE - -putNat :: MonadPut m => Word64 -> m () -putNat = putWord64be - -getNat :: MonadGet m => m Word64 -getNat = getWord64be - -putInt :: MonadPut m => Int64 -> m () -putInt = serializeBE - -getInt :: MonadGet m => m Int64 -getInt = deserializeBE - -putBoolean :: MonadPut m => Bool -> m () -putBoolean False = putWord8 0 -putBoolean True = putWord8 1 - -getBoolean :: MonadGet m => m Bool -getBoolean = go =<< getWord8 where - go 0 = pure False - go 1 = pure True - go t = unknownTag "Boolean" t - -putHash :: MonadPut m => Hash -> m () -putHash h = do - let bs = Hash.toBytes h - putLength (B.length bs) - putByteString bs - -getHash :: MonadGet m => m Hash -getHash = do - len <- getLength - bs <- B.copy <$> Ser.getBytes len - pure $ Hash.fromBytes bs - -putReference :: MonadPut m => Reference -> m () -putReference r = case r of - Reference.Builtin name -> do - putWord8 0 - putText name - Reference.Derived hash i n -> do - putWord8 1 - putHash hash - putLength i - putLength n - -getReference :: MonadGet m => m Reference -getReference = do - tag <- getWord8 - case tag of - 0 -> Reference.Builtin <$> getText - 1 -> Reference.DerivedId <$> (Reference.Id <$> getHash <*> getLength <*> getLength) - _ -> unknownTag "Reference" tag - -putReferent :: MonadPut m => Referent -> m () -putReferent = \case - Referent.Ref r -> do - putWord8 0 - putReference r - Referent.Con r i ct -> do - putWord8 1 - putReference r - putLength i - putConstructorType ct - -putConstructorType :: MonadPut m => CT.ConstructorType -> m () -putConstructorType = \case - CT.Data -> putWord8 0 - CT.Effect -> putWord8 1 - -getReferent :: MonadGet m => m Referent -getReferent = do - tag <- getWord8 - case tag of - 0 -> Referent.Ref <$> getReference - 1 -> Referent.Con <$> getReference <*> getLength <*> getConstructorType - _ -> unknownTag "getReferent" tag - -getConstructorType :: MonadGet m => m CT.ConstructorType -getConstructorType = getWord8 >>= \case - 0 -> pure CT.Data - 1 -> pure CT.Effect - t -> unknownTag "getConstructorType" t - -putMaybe :: MonadPut m => Maybe a -> (a -> m ()) -> m () -putMaybe Nothing _ = putWord8 0 -putMaybe (Just a) putA = putWord8 1 *> putA a - -getMaybe :: MonadGet m => m a -> m (Maybe a) -getMaybe getA = getWord8 >>= \tag -> case tag of - 0 -> pure Nothing - 1 -> Just <$> getA - _ -> unknownTag "Maybe" tag - -putFoldable - :: (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () -putFoldable putA as = do - putLength (length as) - traverse_ putA as - -getList :: MonadGet m => m a -> m [a] -getList a = getLength >>= (`replicateM` a) - -putABT - :: (MonadPut m, Foldable f, Functor f, Ord v) - => (v -> m ()) - -> (a -> m ()) - -> (forall x . (x -> m ()) -> f x -> m ()) - -> ABT.Term f v a - -> m () -putABT putVar putA putF abt = - putFoldable putVar fvs *> go (ABT.annotateBound'' abt) - where - fvs = Set.toList $ ABT.freeVars abt - go (ABT.Term _ (a, env) abt) = putA a *> case abt of - ABT.Var v -> putWord8 0 *> putVarRef env v - ABT.Tm f -> putWord8 1 *> putF go f - ABT.Abs v body -> putWord8 2 *> putVar v *> go body - ABT.Cycle body -> putWord8 3 *> go body - - putVarRef env v = case v `elemIndex` env of - Just i -> putWord8 0 *> putLength i - Nothing -> case v `elemIndex` fvs of - Just i -> putWord8 1 *> putLength i - Nothing -> error "impossible: var not free or bound" - -getABT - :: (MonadGet m, Foldable f, Functor f, Ord v) - => m v - -> m a - -> (forall x . m x -> m (f x)) - -> m (ABT.Term f v a) -getABT getVar getA getF = getList getVar >>= go [] where - go env fvs = do - a <- getA - tag <- getWord8 - case tag of - 0 -> do - tag <- getWord8 - case tag of - 0 -> ABT.annotatedVar a . (env !!) <$> getLength - 1 -> ABT.annotatedVar a . (fvs !!) <$> getLength - _ -> unknownTag "getABT.Var" tag - 1 -> ABT.tm' a <$> getF (go env fvs) - 2 -> do - v <- getVar - body <- go (v:env) fvs - pure $ ABT.abs' a v body - 3 -> ABT.cycle' a <$> go env fvs - _ -> unknownTag "getABT" tag - -putKind :: MonadPut m => Kind -> m () -putKind k = case k of - Kind.Star -> putWord8 0 - Kind.Arrow i o -> putWord8 1 *> putKind i *> putKind o - -getKind :: MonadGet m => m Kind -getKind = getWord8 >>= \tag -> case tag of - 0 -> pure Kind.Star - 1 -> Kind.Arrow <$> getKind <*> getKind - _ -> unknownTag "getKind" tag - -putType :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> Type v a - -> m () -putType putVar putA = putABT putVar putA go where - go putChild t = case t of - Type.Ref r -> putWord8 0 *> putReference r - Type.Arrow i o -> putWord8 1 *> putChild i *> putChild o - Type.Ann t k -> putWord8 2 *> putChild t *> putKind k - Type.App f x -> putWord8 3 *> putChild f *> putChild x - Type.Effect e t -> putWord8 4 *> putChild e *> putChild t - Type.Effects es -> putWord8 5 *> putFoldable putChild es - Type.Forall body -> putWord8 6 *> putChild body - Type.IntroOuter body -> putWord8 7 *> putChild body - -getType :: (MonadGet m, Ord v) - => m v -> m a -> m (Type v a) -getType getVar getA = getABT getVar getA go where - go getChild = getWord8 >>= \tag -> case tag of - 0 -> Type.Ref <$> getReference - 1 -> Type.Arrow <$> getChild <*> getChild - 2 -> Type.Ann <$> getChild <*> getKind - 3 -> Type.App <$> getChild <*> getChild - 4 -> Type.Effect <$> getChild <*> getChild - 5 -> Type.Effects <$> getList getChild - 6 -> Type.Forall <$> getChild - 7 -> Type.IntroOuter <$> getChild - _ -> unknownTag "getType" tag - -putSymbol :: MonadPut m => Symbol -> m () -putSymbol (Symbol id typ) = putLength id *> putText (Var.rawName typ) - -getSymbol :: MonadGet m => m Symbol -getSymbol = Symbol <$> getLength <*> (Var.User <$> getText) - -putPattern :: MonadPut m => (a -> m ()) -> Pattern a -> m () -putPattern putA p = case p of - Pattern.Unbound a -> putWord8 0 *> putA a - Pattern.Var a -> putWord8 1 *> putA a - Pattern.Boolean a b -> putWord8 2 *> putA a *> putBoolean b - Pattern.Int a n -> putWord8 3 *> putA a *> putInt n - Pattern.Nat a n -> putWord8 4 *> putA a *> putNat n - Pattern.Float a n -> putWord8 5 *> putA a *> putFloat n - Pattern.Constructor a r cid ps -> - putWord8 6 - *> putA a - *> putReference r - *> putLength cid - *> putFoldable (putPattern putA) ps - Pattern.As a p -> putWord8 7 *> putA a *> putPattern putA p - Pattern.EffectPure a p -> putWord8 8 *> putA a *> putPattern putA p - Pattern.EffectBind a r cid args k -> - putWord8 9 - *> putA a - *> putReference r - *> putLength cid - *> putFoldable (putPattern putA) args - *> putPattern putA k - Pattern.SequenceLiteral a ps -> - putWord8 10 *> putA a *> putFoldable (putPattern putA) ps - Pattern.SequenceOp a l op r -> - putWord8 11 - *> putA a - *> putPattern putA l - *> putSeqOp op - *> putPattern putA r - Pattern.Text a t -> putWord8 12 *> putA a *> putText t - Pattern.Char a c -> putWord8 13 *> putA a *> putChar c - -putSeqOp :: MonadPut m => SeqOp -> m () -putSeqOp Pattern.Cons = putWord8 0 -putSeqOp Pattern.Snoc = putWord8 1 -putSeqOp Pattern.Concat = putWord8 2 - -getSeqOp :: MonadGet m => m SeqOp -getSeqOp = getWord8 >>= \case - 0 -> pure Pattern.Cons - 1 -> pure Pattern.Snoc - 2 -> pure Pattern.Concat - tag -> unknownTag "SeqOp" tag - -getPattern :: MonadGet m => m a -> m (Pattern a) -getPattern getA = getWord8 >>= \tag -> case tag of - 0 -> Pattern.Unbound <$> getA - 1 -> Pattern.Var <$> getA - 2 -> Pattern.Boolean <$> getA <*> getBoolean - 3 -> Pattern.Int <$> getA <*> getInt - 4 -> Pattern.Nat <$> getA <*> getNat - 5 -> Pattern.Float <$> getA <*> getFloat - 6 -> Pattern.Constructor <$> getA <*> getReference <*> getLength <*> getList - (getPattern getA) - 7 -> Pattern.As <$> getA <*> getPattern getA - 8 -> Pattern.EffectPure <$> getA <*> getPattern getA - 9 -> - Pattern.EffectBind - <$> getA - <*> getReference - <*> getLength - <*> getList (getPattern getA) - <*> getPattern getA - 10 -> Pattern.SequenceLiteral <$> getA <*> getList (getPattern getA) - 11 -> - Pattern.SequenceOp - <$> getA - <*> getPattern getA - <*> getSeqOp - <*> getPattern getA - 12 -> Pattern.Text <$> getA <*> getText - 13 -> Pattern.Char <$> getA <*> getChar - _ -> unknownTag "Pattern" tag - -putTerm :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> Term v a - -> m () -putTerm putVar putA = putABT putVar putA go where - go putChild t = case t of - Term.Int n - -> putWord8 0 *> putInt n - Term.Nat n - -> putWord8 1 *> putNat n - Term.Float n - -> putWord8 2 *> putFloat n - Term.Boolean b - -> putWord8 3 *> putBoolean b - Term.Text t - -> putWord8 4 *> putText t - Term.Blank _ - -> error "can't serialize term with blanks" - Term.Ref r - -> putWord8 5 *> putReference r - Term.Constructor r cid - -> putWord8 6 *> putReference r *> putLength cid - Term.Request r cid - -> putWord8 7 *> putReference r *> putLength cid - Term.Handle h a - -> putWord8 8 *> putChild h *> putChild a - Term.App f arg - -> putWord8 9 *> putChild f *> putChild arg - Term.Ann e t - -> putWord8 10 *> putChild e *> putType putVar putA t - Term.List vs - -> putWord8 11 *> putFoldable putChild vs - Term.If cond t f - -> putWord8 12 *> putChild cond *> putChild t *> putChild f - Term.And x y - -> putWord8 13 *> putChild x *> putChild y - Term.Or x y - -> putWord8 14 *> putChild x *> putChild y - Term.Lam body - -> putWord8 15 *> putChild body - Term.LetRec _ bs body - -> putWord8 16 *> putFoldable putChild bs *> putChild body - Term.Let _ b body - -> putWord8 17 *> putChild b *> putChild body - Term.Match s cases - -> putWord8 18 *> putChild s *> putFoldable (putMatchCase putA putChild) cases - Term.Char c - -> putWord8 19 *> putChar c - Term.TermLink r - -> putWord8 20 *> putReferent r - Term.TypeLink r - -> putWord8 21 *> putReference r - - putMatchCase :: MonadPut m => (a -> m ()) -> (x -> m ()) -> Term.MatchCase a x -> m () - putMatchCase putA putChild (Term.MatchCase pat guard body) = - putPattern putA pat *> putMaybe guard putChild *> putChild body - -getTerm :: (MonadGet m, Ord v) - => m v -> m a -> m (Term v a) -getTerm getVar getA = getABT getVar getA go where - go getChild = getWord8 >>= \tag -> case tag of - 0 -> Term.Int <$> getInt - 1 -> Term.Nat <$> getNat - 2 -> Term.Float <$> getFloat - 3 -> Term.Boolean <$> getBoolean - 4 -> Term.Text <$> getText - 5 -> Term.Ref <$> getReference - 6 -> Term.Constructor <$> getReference <*> getLength - 7 -> Term.Request <$> getReference <*> getLength - 8 -> Term.Handle <$> getChild <*> getChild - 9 -> Term.App <$> getChild <*> getChild - 10 -> Term.Ann <$> getChild <*> getType getVar getA - 11 -> Term.List . Sequence.fromList <$> getList getChild - 12 -> Term.If <$> getChild <*> getChild <*> getChild - 13 -> Term.And <$> getChild <*> getChild - 14 -> Term.Or <$> getChild <*> getChild - 15 -> Term.Lam <$> getChild - 16 -> Term.LetRec False <$> getList getChild <*> getChild - 17 -> Term.Let False <$> getChild <*> getChild - 18 -> Term.Match <$> getChild - <*> getList (Term.MatchCase <$> getPattern getA <*> getMaybe getChild <*> getChild) - 19 -> Term.Char <$> getChar - 20 -> Term.TermLink <$> getReferent - 21 -> Term.TypeLink <$> getReference - _ -> unknownTag "getTerm" tag - -putPair :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a,b) -> m () -putPair putA putB (a,b) = putA a *> putB b - -getPair :: MonadGet m => m a -> m b -> m (a,b) -getPair = liftA2 (,) - -putTuple3' - :: MonadPut m - => (a -> m ()) - -> (b -> m ()) - -> (c -> m ()) - -> (a, b, c) - -> m () -putTuple3' putA putB putC (a, b, c) = putA a *> putB b *> putC c - -getTuple3 :: MonadGet m => m a -> m b -> m c -> m (a,b,c) -getTuple3 = liftA3 (,,) - -putRelation :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Relation a b -> m () -putRelation putA putB r = putFoldable (putPair putA putB) (Relation.toList r) - -getRelation :: (MonadGet m, Ord a, Ord b) => m a -> m b -> m (Relation a b) -getRelation getA getB = Relation.fromList <$> getList (getPair getA getB) - -putMap :: MonadPut m => (a -> m ()) -> (b -> m ()) -> Map a b -> m () -putMap putA putB m = putFoldable (putPair putA putB) (Map.toList m) - -getMap :: (MonadGet m, Ord a) => m a -> m b -> m (Map a b) -getMap getA getB = Map.fromList <$> getList (getPair getA getB) - -putTermEdit :: MonadPut m => TermEdit -> m () -putTermEdit (TermEdit.Replace r typing) = - putWord8 1 *> putReference r *> case typing of - TermEdit.Same -> putWord8 1 - TermEdit.Subtype -> putWord8 2 - TermEdit.Different -> putWord8 3 -putTermEdit TermEdit.Deprecate = putWord8 2 - -getTermEdit :: MonadGet m => m TermEdit -getTermEdit = getWord8 >>= \case - 1 -> TermEdit.Replace <$> getReference <*> (getWord8 >>= \case - 1 -> pure TermEdit.Same - 2 -> pure TermEdit.Subtype - 3 -> pure TermEdit.Different - t -> unknownTag "TermEdit.Replace" t - ) - 2 -> pure TermEdit.Deprecate - t -> unknownTag "TermEdit" t - -putTypeEdit :: MonadPut m => TypeEdit -> m () -putTypeEdit (TypeEdit.Replace r) = putWord8 1 *> putReference r -putTypeEdit TypeEdit.Deprecate = putWord8 2 - -getTypeEdit :: MonadGet m => m TypeEdit -getTypeEdit = getWord8 >>= \case - 1 -> TypeEdit.Replace <$> getReference - 2 -> pure TypeEdit.Deprecate - t -> unknownTag "TypeEdit" t - -putStar3 - :: MonadPut m - => (f -> m ()) - -> (d1 -> m ()) - -> (d2 -> m ()) - -> (d3 -> m ()) - -> Star3 f d1 d2 d3 - -> m () -putStar3 putF putD1 putD2 putD3 s = do - putFoldable putF (Star3.fact s) - putRelation putF putD1 (Star3.d1 s) - putRelation putF putD2 (Star3.d2 s) - putRelation putF putD3 (Star3.d3 s) - -getStar3 - :: (MonadGet m, Ord fact, Ord d1, Ord d2, Ord d3) - => m fact - -> m d1 - -> m d2 - -> m d3 - -> m (Star3 fact d1 d2 d3) -getStar3 getF getD1 getD2 getD3 = - Star3.Star3 - <$> (Set.fromList <$> getList getF) - <*> getRelation getF getD1 - <*> getRelation getF getD2 - <*> getRelation getF getD3 - -putBranchStar :: MonadPut m => (a -> m ()) -> (n -> m ()) -> Branch.Star a n -> m () -putBranchStar putA putN = - putStar3 putA putN putMetadataType (putPair putMetadataType putMetadataValue) - -getBranchStar :: (Ord a, Ord n, MonadGet m) => m a -> m n -> m (Branch.Star a n) -getBranchStar getA getN = getStar3 getA getN getMetadataType (getPair getMetadataType getMetadataValue) - -putChar :: MonadPut m => Char -> m () -putChar = serialize . VarInt . fromEnum - -getChar :: MonadGet m => m Char -getChar = toEnum . unVarInt <$> deserialize - -putNameSegment :: MonadPut m => NameSegment -> m () -putNameSegment = putText . NameSegment.toText - -getNameSegment :: MonadGet m => m NameSegment -getNameSegment = NameSegment <$> getText - -putRawBranch :: MonadPut m => Branch.Raw -> m () -putRawBranch (Branch.Raw terms types children edits) = do - putBranchStar putReferent putNameSegment terms - putBranchStar putReference putNameSegment types - putMap putNameSegment (putHash . unRawHash) children - putMap putNameSegment putHash edits - -getMetadataType :: MonadGet m => m Metadata.Type -getMetadataType = getReference - -putMetadataType :: MonadPut m => Metadata.Type -> m () -putMetadataType = putReference - -getMetadataValue :: MonadGet m => m Metadata.Value -getMetadataValue = getReference - -putMetadataValue :: MonadPut m => Metadata.Value -> m () -putMetadataValue = putReference - -getRawBranch :: MonadGet m => m Branch.Raw -getRawBranch = - Branch.Raw - <$> getBranchStar getReferent getNameSegment - <*> getBranchStar getReference getNameSegment - <*> getMap getNameSegment (RawHash <$> getHash) - <*> getMap getNameSegment getHash - --- `getBranchDependencies` consumes the same data as `getRawBranch` -getBranchDependencies :: MonadGet m => m (BD.Branches n, BD.Dependencies) -getBranchDependencies = do - (terms1, types1) <- getTermStarDependencies - (terms2, types2) <- getTypeStarDependencies - childHashes <- fmap (RawHash . snd) <$> getList (getPair skipText getHash) - editHashes <- Set.fromList . fmap snd <$> getList (getPair skipText getHash) - pure ( childHashes `zip` repeat Nothing - , BD.Dependencies editHashes (terms1 <> terms2) (types1 <> types2) ) - where - -- returns things, metadata types, metadata values - getStarReferences :: - (MonadGet m, Ord r) => m r -> m ([r], [Metadata.Value]) - getStarReferences getR = do - void $ getList getR -- throw away the `facts` - -- d1: references and namesegments - rs :: [r] <- fmap fst <$> getList (getPair getR skipText) - -- d2: metadata type index - void $ getList (getPair getR getMetadataType) - -- d3: metadata (type, value) index - (_metadataTypes, metadataValues) <- unzip . fmap snd <$> - getList (getPair getR (getPair getMetadataType getMetadataValue)) - pure (rs, metadataValues) - - getTermStarDependencies :: MonadGet m => m (Set Reference.Id, Set Reference.Id) - getTermStarDependencies = do - (referents, mdValues) <- getStarReferences getReferent - let termIds = Set.fromList $ - [ i | Referent.Ref (Reference.DerivedId i) <- referents ] ++ - [ i | Reference.DerivedId i <- mdValues ] - declIds = Set.fromList $ - [ i | Referent.Con (Reference.DerivedId i) _cid _ct <- referents ] - pure (termIds, declIds) - - getTypeStarDependencies :: MonadGet m => m (Set Reference.Id, Set Reference.Id) - getTypeStarDependencies = do - (references, mdValues) <- getStarReferences getReference - let termIds = Set.fromList $ [ i | Reference.DerivedId i <- mdValues ] - declIds = Set.fromList $ [ i | Reference.DerivedId i <- references ] - pure (termIds, declIds) - -putDataDeclaration :: (MonadPut m, Ord v) - => (v -> m ()) -> (a -> m ()) - -> DataDeclaration v a - -> m () -putDataDeclaration putV putA decl = do - putModifier $ DataDeclaration.modifier decl - putA $ DataDeclaration.annotation decl - putFoldable putV (DataDeclaration.bound decl) - putFoldable (putTuple3' putA putV (putType putV putA)) (DataDeclaration.constructors' decl) - -getDataDeclaration :: (MonadGet m, Ord v) => m v -> m a -> m (DataDeclaration v a) -getDataDeclaration getV getA = DataDeclaration.DataDeclaration <$> - getModifier <*> - getA <*> - getList getV <*> - getList (getTuple3 getA getV (getType getV getA)) - -putModifier :: MonadPut m => DataDeclaration.Modifier -> m () -putModifier DataDeclaration.Structural = putWord8 0 -putModifier (DataDeclaration.Unique txt) = putWord8 1 *> putText txt - -getModifier :: MonadGet m => m DataDeclaration.Modifier -getModifier = getWord8 >>= \case - 0 -> pure DataDeclaration.Structural - 1 -> DataDeclaration.Unique <$> getText - tag -> unknownTag "DataDeclaration.Modifier" tag - -putEffectDeclaration :: - (MonadPut m, Ord v) => (v -> m ()) -> (a -> m ()) -> EffectDeclaration v a -> m () -putEffectDeclaration putV putA (DataDeclaration.EffectDeclaration d) = - putDataDeclaration putV putA d - -getEffectDeclaration :: (MonadGet m, Ord v) => m v -> m a -> m (EffectDeclaration v a) -getEffectDeclaration getV getA = - DataDeclaration.EffectDeclaration <$> getDataDeclaration getV getA - -putEither :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> Either a b -> m () -putEither putL _ (Left a) = putWord8 0 *> putL a -putEither _ putR (Right b) = putWord8 1 *> putR b - -getEither :: MonadGet m => m a -> m b -> m (Either a b) -getEither getL getR = getWord8 >>= \case - 0 -> Left <$> getL - 1 -> Right <$> getR - tag -> unknownTag "Either" tag - -formatSymbol :: S.Format Symbol -formatSymbol = S.Format getSymbol putSymbol - -putEdits :: MonadPut m => Patch -> m () -putEdits edits = - putRelation putReference putTermEdit (Patch._termEdits edits) >> - putRelation putReference putTypeEdit (Patch._typeEdits edits) - -getEdits :: MonadGet m => m Patch -getEdits = Patch <$> getRelation getReference getTermEdit - <*> getRelation getReference getTypeEdit diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs deleted file mode 100644 index 591f1fd8c5..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/SlimCopyRegenerateIndex.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} - - -module Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex (syncToDirectory) where - -import Unison.Prelude - -import Control.Lens -import Control.Monad.State.Strict (MonadState, evalStateT) -import Control.Monad.Writer.Strict (MonadWriter, execWriterT) -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Set as Set -import U.Util.Timing (time) -import Unison.Codebase (CodebasePath) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.FileCodebase.Branch (Branch (..)) -import qualified Unison.Codebase.FileCodebase.Branch as Branch -import qualified Unison.Codebase.FileCodebase.Branch.Dependencies as BD -import qualified Unison.Codebase.FileCodebase.DataDeclaration as DD -import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD -import qualified Unison.Codebase.FileCodebase.Patch as Patch -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 -import qualified Unison.Codebase.FileCodebase.Term as Term -import qualified Unison.Codebase.FileCodebase.TermEdit as TermEdit -import Unison.Codebase.FileCodebase.Type (Type) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.Codebase.FileCodebase.TypeEdit as TypeEdit -import qualified Unison.Codebase.Serialization as S -import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.Codebase.SyncMode as SyncMode -import qualified Unison.Referent' as Referent -import Unison.Util.Monoid (foldMapM) -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as Relation -import Unison.Var (Var) -import qualified Unison.WatchKind as WK -import UnliftIO.Directory (doesFileExist) - -import Data.Monoid.Generic -import Unison.Codebase.FileCodebase.Common - -data SyncedEntities = SyncedEntities - { _syncedTerms :: Set Reference.Id - , _syncedDecls :: Set Reference.Id - , _syncedEdits :: Set Branch.EditHash - , _syncedBranches :: Set Branch.Hash - , _dependentsIndex :: Relation Reference Reference.Id - , _typeIndex :: Relation Reference Referent.Id - , _typeMentionsIndex :: Relation Reference Referent.Id - } deriving Generic - deriving Show - deriving Semigroup via GenericSemigroup SyncedEntities - deriving Monoid via GenericMonoid SyncedEntities - -makeLenses ''SyncedEntities - -syncToDirectory :: forall m v a - . MonadIO m - => Var v - => S.Format v - -> S.Format a - -> CodebasePath - -> CodebasePath - -> SyncMode - -> Branch m - -> m () -syncToDirectory fmtV fmtA = syncToDirectory' (S.get fmtV) (S.get fmtA) - -data Error - = MissingBranch Branch.Hash - | MissingPatch Branch.EditHash - | MissingTerm Reference.Id - | MissingTypeOfTerm Reference.Id - | MissingDecl Reference.Id - | InvalidBranch Branch.Hash - | InvalidTerm Reference.Id - | InvalidTypeOfTerm Reference.Id - | InvalidDecl Reference.Id - deriving (Eq, Ord, Show) - -syncToDirectory' :: forall m v a - . MonadIO m - => Var v - => S.Get v - -> S.Get a - -> CodebasePath - -> CodebasePath - -> SyncMode - -> Branch m - -> m () -syncToDirectory' getV getA srcPath destPath mode newRoot = - let warnMissingEntities = False in - flip evalStateT mempty $ do -- MonadState s m - (deps, errors) <- time "Sync Branches" $ execWriterT $ - processBranches [(Branch.headHash newRoot - ,Just . pure . Branch.transform (lift . lift) $ newRoot)] - errors' <- time "Sync Definitions" $ - execWriterT $ processDependencies (BD.to' deps) - time "Write indices" $ do - lift . writeDependentsIndex =<< use dependentsIndex - lift . writeTypeIndex =<< use typeIndex - lift . writeTypeMentionsIndex =<< use typeMentionsIndex - when (warnMissingEntities) $ for_ (errors <> errors') traceShowM - where - writeDependentsIndex :: MonadIO m => Relation Reference Reference.Id -> m () - writeDependentsIndex = writeIndexHelper (\k v -> touchIdFile v (dependentsDir destPath k)) - writeTypeIndex, writeTypeMentionsIndex :: MonadIO m => Relation Reference Referent.Id -> m () - writeTypeIndex = - writeIndexHelper (\k v -> touchReferentIdFile v (typeIndexDir destPath k)) - writeTypeMentionsIndex = - writeIndexHelper (\k v -> touchReferentIdFile v (typeMentionsIndexDir destPath k)) - writeIndexHelper - :: forall m a b. MonadIO m => (a -> b -> m ()) -> Relation a b -> m () - writeIndexHelper touchIndexFile index = - traverse_ (uncurry touchIndexFile) (Relation.toList index) - processBranches :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (BD.Dependencies, Set Error) m - => [(Branch.Hash, Maybe (m (Branch m)))] - -> m () - processBranches [] = pure () - -- for each branch, - processBranches ((h, mmb) : rest) = - let tellError = Writer.tell . (mempty,) . Set.singleton - tellDependencies = Writer.tell . (,mempty) in - -- if hash exists at the destination, skip it, mark it done - ifNeedsSyncing h destPath branchPath syncedBranches - (\h -> - -- else if hash exists at the source, enqueue its dependencies, copy it, mark it done - ifM (doesFileExist (branchPath srcPath h)) - (do - (branches, deps) <- BD.fromRawCausal <$> - (deserializeRawBranchDependencies tellError srcPath h) - copyFileWithParents (branchPath srcPath h) (branchPath destPath h) - tellDependencies deps - processBranches (branches ++ rest)) - -- else if it's in memory, enqueue its dependencies, write it, mark it done - case mmb of - Just mb -> do - b <- mb - let (branches, deps) = BD.fromBranch b - let causalRaw = Branch.toCausalRaw b - serializeRawBranch destPath h causalRaw - tellDependencies deps - processBranches (branches ++ rest) - -- else -- error? - Nothing -> do - tellError (MissingBranch h) - processBranches rest - ) - (processBranches rest) - processDependencies :: forall n - . MonadIO n - => MonadState SyncedEntities n - => MonadWriter (Set Error) n - => BD.Dependencies' - -> n () - processDependencies = \case - -- for each patch - -- enqueue its target term and type references - BD.Dependencies' (editHash : editHashes) terms decls -> - -- This code assumes that patches are always available on disk, - -- not ever just held in memory with `pure`. If that's not the case, - -- then we can do something similar to what we did with branches. - ifNeedsSyncing editHash destPath editsPath syncedEdits - (\h -> do - patch <- deserializeEdits srcPath h - -- I'm calling all the replacement terms dependents of the patches. - -- If we're supposed to replace X with Y, we don't necessarily need X, - -- but we do need Y. - let newTerms, newDecls :: [Reference.Id] - newTerms = [ i | TermEdit.Replace (Reference.DerivedId i) _ <- - toList . Relation.ran $ Patch._termEdits patch] - newDecls = [ i | TypeEdit.Replace (Reference.DerivedId i) <- - toList . Relation.ran $ Patch._typeEdits patch] - ifM (doesFileExist (editsPath srcPath h)) - (do - copyFileWithParents (editsPath srcPath h) (editsPath destPath h) - processDependencies $ - BD.Dependencies' editHashes (newTerms ++ terms) (newDecls ++ decls)) - (do - tellError (MissingPatch h) - (processDependencies $ BD.Dependencies' editHashes terms decls))) - (processDependencies $ BD.Dependencies' editHashes terms decls) - - -- for each term id - BD.Dependencies' [] (termHash : termHashes) decls -> - -- if it exists at the destination, skip it, mark it done - ifNeedsSyncing termHash destPath termPath syncedTerms - (\h -> do - -- else if it exists at the source, - ifM (doesFileExist (termPath srcPath h)) - (do - -- copy it, - -- load it, - -- enqueue its dependencies for syncing - -- enqueue its type's type dependencies for syncing - -- enqueue its type's dependencies, type & type mentions into respective indices - -- and continue - (newTerms, newDecls) <- enqueueTermDependencies h - processDependencies $ - BD.Dependencies' [] (newTerms ++ termHashes) (newDecls ++ decls) - ) - -- else -- an error? - (do - tellError (MissingTerm h) - (processDependencies $ BD.Dependencies' [] termHashes decls))) - (processDependencies $ BD.Dependencies' [] termHashes decls) - -- for each decl id - BD.Dependencies' [] [] (declHash : declHashes) -> - -- if it exists at the destination, skip it, mark it done - ifNeedsSyncing declHash destPath declPath syncedDecls - (\h -> do - -- else if it exists at the source, - ifM (doesFileExist (declPath srcPath h)) - -- copy it, - -- load it, - -- enqueue its type dependencies for syncing - -- for each constructor, - -- enqueue its dependencies, type, type mentions into respective indices - (do - newDecls <- copyAndIndexDecls h - processDependencies $ BD.Dependencies' [] [] (newDecls ++ declHashes)) - (do - tellError (MissingDecl h) - (processDependencies $ BD.Dependencies' [] [] declHashes))) - (processDependencies $ BD.Dependencies' [] [] declHashes) - BD.Dependencies' [] [] [] -> pure () - copyAndIndexDecls :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (Set Error) m - => Reference.Id - -> m [Reference.Id] - copyAndIndexDecls h = (getDecl getV getA srcPath h :: m (Maybe (DD.Decl v a))) >>= \case - Just decl -> do - copyFileWithParents (declPath srcPath h) (declPath destPath h) - let referentTypes :: [(Referent.Id, Type v a)] - referentTypes = DD.declConstructorReferents h decl - `zip` (DD.constructorTypes . DD.asDataDecl) decl - flip foldMapM referentTypes \(r, typ) -> do - let dependencies = toList (Type.dependencies typ) - dependentsIndex <>= Relation.fromManyDom dependencies h - let typeForIndexing = Type.removeAllEffectVars typ - let typeReference = Type.toReference typeForIndexing - let typeMentions = Type.toReferenceMentions typeForIndexing - typeIndex <>= Relation.singleton typeReference r - typeMentionsIndex <>= Relation.fromManyDom typeMentions r - pure [ i | Reference.DerivedId i <- dependencies ] - Nothing -> tellError (InvalidDecl h) $> mempty - - enqueueTermDependencies :: forall m - . MonadIO m - => MonadState SyncedEntities m - => MonadWriter (Set Error) m - => Reference.Id - -> m ([Reference.Id], [Reference.Id]) - enqueueTermDependencies h = getTerm getV getA srcPath h >>= \case - Just term -> do - let (typeDeps, termDeps) = partitionEithers . fmap LD.toReference . toList - $ Term.labeledDependencies term - ifM (doesFileExist (typePath srcPath h)) - (getTypeOfTerm getV getA srcPath h >>= \case - Just typ -> do - copyFileWithParents (termPath srcPath h) (termPath destPath h) - copyFileWithParents (typePath srcPath h) (typePath destPath h) - whenM (doesFileExist $ watchPath srcPath WK.TestWatch h) $ - copyFileWithParents (watchPath srcPath WK.TestWatch h) - (watchPath destPath WK.TestWatch h) - let typeDeps' = toList (Type.dependencies typ) - let typeForIndexing = Type.removeAllEffectVars typ - let typeReference = Type.toReference typeForIndexing - let typeMentions = Type.toReferenceMentions typeForIndexing - dependentsIndex <>= - Relation.fromManyDom (typeDeps ++ typeDeps' ++ termDeps) h - typeIndex <>= - Relation.singleton typeReference (Referent.Ref' h) - typeMentionsIndex <>= - Relation.fromManyDom typeMentions (Referent.Ref' h) - let newDecls = [ i | Reference.DerivedId i <- typeDeps ++ typeDeps'] - let newTerms = [ i | Reference.DerivedId i <- termDeps ] - pure (newTerms, newDecls) - Nothing -> tellError (InvalidTypeOfTerm h) $> mempty) - (tellError (MissingTypeOfTerm h) $> mempty) - Nothing -> tellError (InvalidTerm h) $> mempty - - deserializeRawBranchDependencies :: forall m - . MonadIO m - => (Error -> m ()) - -> CodebasePath - -> Causal.Deserialize m Branch.Raw (BD.Branches m, BD.Dependencies) - deserializeRawBranchDependencies tellError root h = - S.getFromFile (V1.getCausal0 V1.getBranchDependencies) (branchPath root h) >>= \case - Nothing -> tellError (InvalidBranch h) $> Causal.RawOne mempty - Just results -> pure results - tellError :: forall m a. MonadWriter (Set a) m => a -> m () - tellError = Writer.tell . Set.singleton - - -- Use State and Lens to do some specified thing at most once, to create a file. - ifNeedsSyncing :: forall m s h. (MonadIO m, MonadState s m, Ord h) - => h - -> CodebasePath - -> (CodebasePath -> h -> FilePath) -- done if this filepath exists - -> SimpleLens s (Set h) -- lens to track if `h` is already done - -> (h -> m ()) -- do! - -> m () -- don't - -> m () - ifNeedsSyncing h destPath getFilename l doSync dontSync = - ifM (use (l . to (Set.member h))) dontSync $ do - l %= Set.insert h - if mode == SyncMode.Complete then doSync h - else ifM (doesFileExist (getFilename destPath h)) dontSync (doSync h) diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs deleted file mode 100644 index cd3cad9405..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Term.hs +++ /dev/null @@ -1,1120 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Term where - -import Unison.Prelude - -import Prelude hiding (and,or) -import Control.Monad.State (evalState) -import qualified Control.Monad.Writer.Strict as Writer -import Data.Bifunctor (second) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Sequence as Sequence -import Prelude.Extras (Eq1(..), Show1(..)) -import Text.Show -import qualified Unison.ABT as ABT -import qualified Unison.Blank as B -import qualified Unison.Hash as Hash -import Unison.Hashable (Hashable1, accumulateToken) -import qualified Unison.Hashable as Hashable -import Unison.Codebase.FileCodebase.Pattern (Pattern) -import qualified Unison.Codebase.FileCodebase.Pattern as Pattern -import Unison.Codebase.FileCodebase.Reference (Reference, pattern Builtin) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Reference.Util as ReferenceUtil -import Unison.Codebase.FileCodebase.Referent (Referent) -import qualified Unison.Codebase.FileCodebase.Referent as Referent -import Unison.Codebase.FileCodebase.Type (Type) -import qualified Unison.Codebase.FileCodebase.Type as Type -import qualified Unison.ConstructorType as CT -import Unison.Util.List (multimap) -import Unison.Var (Var) -import qualified Unison.Var as Var -import Unsafe.Coerce -import Unison.Symbol (Symbol) -import qualified Unison.Codebase.FileCodebase.LabeledDependency as LD -import Unison.Codebase.FileCodebase.LabeledDependency (LabeledDependency) - --- This gets reexported; should maybe live somewhere other than Pattern, though. -type ConstructorId = Pattern.ConstructorId - -data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a - deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) - --- | Base functor for terms in the Unison language --- We need `typeVar` because the term and type variables may differ. -data F typeVar typeAnn patternAnn a - = Int Int64 - | Nat Word64 - | Float Double - | Boolean Bool - | Text Text - | Char Char - | Blank (B.Blank typeAnn) - | Ref Reference - -- First argument identifies the data type, - -- second argument identifies the constructor - | Constructor Reference ConstructorId - | Request Reference ConstructorId - | Handle a a - | App a a - | Ann a (Type typeVar typeAnn) - | List (Seq a) - | If a a a - | And a a - | Or a a - | Lam a - -- Note: let rec blocks have an outer ABT.Cycle which introduces as many - -- variables as there are bindings - | LetRec IsTop [a] a - -- Note: first parameter is the binding, second is the expression which may refer - -- to this let bound variable. Constructed as `Let b (abs v e)` - | Let IsTop a a - -- Pattern matching / eliminating data types, example: - -- case x of - -- Just n -> rhs1 - -- Nothing -> rhs2 - -- - -- translates to - -- - -- Match x - -- [ (Constructor 0 [Var], ABT.abs n rhs1) - -- , (Constructor 1 [], rhs2) ] - | Match a [MatchCase patternAnn a] - | TermLink Referent - | TypeLink Reference - deriving (Foldable,Functor,Generic,Generic1,Traversable) - -type IsTop = Bool - --- | Like `Term v`, but with an annotation of type `a` at every level in the tree -type Term v a = Term2 v a a v a --- | Allow type variables and term variables to differ -type Term' vt v a = Term2 vt a a v a --- | Allow type variables, term variables, type annotations and term annotations --- to all differ -type Term2 vt at ap v a = ABT.Term (F vt at ap) v a --- | Like `Term v a`, but with only () for type and pattern annotations. -type Term3 v a = Term2 v () () v a - --- | Terms are represented as ABTs over the base functor F, with variables in `v` -type Term0 v = Term v () --- | Terms with type variables in `vt`, and term variables in `v` -type Term0' vt v = Term' vt v () - --- Prepare a term for type-directed name resolution by replacing --- any remaining free variables with blanks to be resolved by TDNR -prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b -prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t - where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = - Just $ resolve (a, bound) a (Text.unpack $ Var.name v) - f _ = Nothing - -amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 -amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) - -patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a -patternMap f = go where - go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of - ABT.Abs v t -> ABT.Abs v (go t) - ABT.Var v -> ABT.Var v - ABT.Cycle t -> ABT.Cycle (go t) - ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ - MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) - -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg - ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) - -vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a -vmap f = ABT.vmap f . typeMap (ABT.vmap f) - -vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a -vtmap f = typeMap (ABT.vmap f) - -typeMap - :: Ord vt2 - => (Type vt at -> Type vt2 at2) - -> Term2 vt at ap v a - -> Term2 vt2 at2 ap v a -typeMap f = go - where - go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of - ABT.Abs v t -> ABT.Abs v (go t) - ABT.Var v -> ABT.Var v - ABT.Cycle t -> ABT.Cycle (go t) - ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) - -- Safe since `Ann` is only ctor that has embedded `Type v` arg - -- otherwise we'd have to manually match on every non-`Ann` ctor - ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) - -extraMap' - :: (Ord vt, Ord vt') - => (vt -> vt') - -> (at -> at') - -> (ap -> ap') - -> Term2 vt at ap v a - -> Term2 vt' at' ap' v a -extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) - -extraMap - :: (Ord vt, Ord vt') - => (vt -> vt') - -> (at -> at') - -> (ap -> ap') - -> F vt at ap a - -> F vt' at' ap' a -extraMap vtf atf apf = \case - Int x -> Int x - Nat x -> Nat x - Float x -> Float x - Boolean x -> Boolean x - Text x -> Text x - Char x -> Char x - Blank x -> Blank (fmap atf x) - Ref x -> Ref x - Constructor x y -> Constructor x y - Request x y -> Request x y - Handle x y -> Handle x y - App x y -> App x y - Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) - List x -> List x - If x y z -> If x y z - And x y -> And x y - Or x y -> Or x y - Lam x -> Lam x - LetRec x y z -> LetRec x y z - Let x y z -> Let x y z - Match tm l -> Match tm (map (matchCaseExtraMap apf) l) - TermLink r -> TermLink r - TypeLink r -> TypeLink r - -matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a -matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y - -unannotate - :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v -unannotate = go - where - go :: Term2 vt at ap v a -> Term0' vt v - go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) - go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) - go (ABT.Var' v ) = ABT.var v - go (ABT.Tm' f ) = case go <$> f of - Ann e t -> ABT.tm (Ann e (void t)) - Match scrutinee branches -> - let unann (MatchCase pat guard body) = MatchCase (void pat) guard body - in ABT.tm (Match scrutinee (unann <$> branches)) - f' -> ABT.tm (unsafeCoerce f') - go _ = error "unpossible" - -wrapV :: Ord v => Term v a -> Term (ABT.V v) a -wrapV = vmap ABT.Bound - --- | All variables mentioned in the given term. --- Includes both term and type variables, both free and bound. -allVars :: Ord v => Term v a -> Set v -allVars tm = Set.fromList $ - ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] - where - allTypes tm = case tm of - Ann' e tp -> tp : allTypes e - _ -> foldMap allTypes $ ABT.out tm - -freeVars :: Term' vt v a -> Set v -freeVars = ABT.freeVars - -freeTypeVars :: Ord vt => Term' vt v a -> Set vt -freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t - -freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] -freeTypeVarAnnotations e = multimap $ go Set.empty e where - go bound tm = case tm of - Var' _ -> mempty - Ann' e (Type.stripIntroOuters -> t1) -> let - bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs - _ -> bound - in go bound' e <> ABT.freeVarOccurrences bound t1 - ABT.Tm' f -> foldMap (go bound) f - (ABT.out -> ABT.Abs _ body) -> go bound body - (ABT.out -> ABT.Cycle body) -> go bound body - _ -> error "unpossible" - -substTypeVars :: (Ord v, Var vt) - => [(vt, Type vt b)] - -> Term' vt v a - -> Term' vt v a -substTypeVars subs e = foldl' go e subs where - go e (vt, t) = substTypeVar vt t e - --- Capture-avoiding substitution of a type variable inside a term. This --- will replace that type variable wherever it appears in type signatures of --- the term, avoiding capture by renaming ∀-binders. -substTypeVar - :: (Ord v, ABT.Var vt) - => vt - -> Type vt b - -> Term' vt v a - -> Term' vt v a -substTypeVar vt ty = go Set.empty where - go bound tm | Set.member vt bound = tm - go bound tm = let loc = ABT.annotation tm in case tm of - Var' _ -> tm - Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where - fvs = ABT.freeVars ty - -- if the ∀ introduces a variable, v, which is free in `ty`, we pick a new - -- variable name for v which is unique, v', and rename v to v' in e. - uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let - v = ABT.variable body - v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v - t2 = ABT.bindInheritAnnotation body (Type.var() v2) - in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 - uncapture vs e t0 = let - t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs - bound' = case Type.unForalls (Type.stripIntroOuters t) of - Nothing -> bound - Just (vs, _) -> bound <> Set.fromList vs - t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) - in ann loc (go bound' e) (Type.freeVarsToOuters bound t') - ABT.Tm' f -> ABT.tm' loc (go bound <$> f) - (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) - (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) - _ -> error "unpossible" - -renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a -renameTypeVar old new = go Set.empty where - go bound tm | Set.member old bound = tm - go bound tm = let loc = ABT.annotation tm in case tm of - Var' _ -> tm - Ann' e t -> let - bound' = case Type.unForalls (Type.stripIntroOuters t) of - Nothing -> bound - Just (vs, _) -> bound <> Set.fromList vs - t' = ABT.rename old new (Type.stripIntroOuters t) - in ann loc (go bound' e) (Type.freeVarsToOuters bound t') - ABT.Tm' f -> ABT.tm' loc (go bound <$> f) - (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) - (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) - _ -> error "unpossible" - --- Converts free variables to bound variables using forall or introOuter. Example: --- --- foo : x -> x --- foo a = --- r : x --- r = a --- r --- --- This becomes: --- --- foo : ∀ x . x -> x --- foo a = --- r : outer x . x -- FYI, not valid syntax --- r = a --- r --- --- More specifically: in the expression `e : t`, unbound lowercase variables in `t` --- are bound with foralls, and any ∀-quantified type variables are made bound in --- `e` and its subexpressions. The result is a term with no lowercase free --- variables in any of its type signatures, with outer references represented --- with explicit `introOuter` binders. The resulting term may have uppercase --- free variables that are still unbound. -generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a -generalizeTypeSignatures = go Set.empty where - go bound tm = let loc = ABT.annotation tm in case tm of - Var' _ -> tm - Ann' e (Type.generalizeLowercase bound -> t) -> let - bound' = case Type.unForalls t of - Nothing -> bound - Just (vs, _) -> bound <> Set.fromList vs - in ann loc (go bound' e) (Type.freeVarsToOuters bound t) - ABT.Tm' f -> ABT.tm' loc (go bound <$> f) - (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) - (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) - _ -> error "unpossible" - --- nicer pattern syntax - -pattern Var' v <- ABT.Var' v -pattern Cycle' xs t <- ABT.Cycle' xs t -pattern Abs' subst <- ABT.Abs' subst -pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) -pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) -pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) -pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) -pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) -pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) -pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) -pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) -pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) -pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) -pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) -pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) -pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) -pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) -pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) -pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) -pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) -pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) -pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) -pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) -pattern Apps' f args <- (unApps -> Just (f, args)) --- begin pretty-printer helper patterns -pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) -pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) -pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) -pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) --- end pretty-printer helper patterns -pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) -pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) -pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) - -pattern Delay' body <- (unDelay -> Just body) -unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) -unDelay tm = case ABT.out tm of - ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) - | Set.notMember v (ABT.freeVars body) - -> Just body - _ -> Nothing - -pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) -pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) -pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) -pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) -pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) -pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) -pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) -pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) -pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) -pattern Lets' bs e <- (unLet -> Just (bs, e)) -pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) -pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) -pattern LetRec' subst <- (unLetRec -> Just (_, subst)) -pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) -pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) -pattern LetRecNamedAnnotatedTop' top ann bs e <- - (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) - -fresh :: Var v => Term0 v -> v -> v -fresh = ABT.fresh - --- some smart constructors - -var :: a -> v -> Term2 vt at ap v a -var = ABT.annotatedVar - -var' :: Var v => Text -> Term0' vt v -var' = var() . Var.named - -ref :: Ord v => a -> Reference -> Term2 vt at ap v a -ref a r = ABT.tm' a (Ref r) - -pattern Referent' r <- (unReferent -> Just r) - -unReferent :: Term2 vt at ap v a -> Maybe Referent -unReferent (Ref' r) = Just $ Referent.Ref r -unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data -unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect -unReferent _ = Nothing - -refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a -refId a = ref a . Reference.DerivedId - -termLink :: Ord v => a -> Referent -> Term2 vt at ap v a -termLink a r = ABT.tm' a (TermLink r) - -typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a -typeLink a r = ABT.tm' a (TypeLink r) - -builtin :: Ord v => a -> Text -> Term2 vt at ap v a -builtin a n = ref a (Reference.Builtin n) - -float :: Ord v => a -> Double -> Term2 vt at ap v a -float a d = ABT.tm' a (Float d) - -boolean :: Ord v => a -> Bool -> Term2 vt at ap v a -boolean a b = ABT.tm' a (Boolean b) - -int :: Ord v => a -> Int64 -> Term2 vt at ap v a -int a d = ABT.tm' a (Int d) - -nat :: Ord v => a -> Word64 -> Term2 vt at ap v a -nat a d = ABT.tm' a (Nat d) - -text :: Ord v => a -> Text -> Term2 vt at ap v a -text a = ABT.tm' a . Text - -char :: Ord v => a -> Char -> Term2 vt at ap v a -char a = ABT.tm' a . Char - -watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a -watch a note e = - apps' (builtin a "Debug.watch") [text a (Text.pack note), e] - -watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a -watchMaybe Nothing e = e -watchMaybe (Just note) e = watch (ABT.annotation e) note e - -blank :: Ord v => a -> Term2 vt at ap v a -blank a = ABT.tm' a (Blank B.Blank) - -placeholder :: Ord v => a -> String -> Term2 vt a ap v a -placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) - -resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at -resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) - -constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a -constructor a ref n = ABT.tm' a (Constructor ref n) - -request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a -request a ref n = ABT.tm' a (Request ref n) - --- todo: delete and rename app' to app -app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v -app_ f arg = ABT.tm (App f arg) - -app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -app a f arg = ABT.tm' a (App f arg) - -match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a -match a scrutinee branches = ABT.tm' a (Match scrutinee branches) - -handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -handle a h block = ABT.tm' a (Handle h block) - -and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -and a x y = ABT.tm' a (And x y) - -or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -or a x y = ABT.tm' a (Or x y) - -list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a -list a es = list' a (Sequence.fromList es) - -list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a -list' a es = ABT.tm' a (List es) - -apps - :: Ord v - => Term2 vt at ap v a - -> [(a, Term2 vt at ap v a)] - -> Term2 vt at ap v a -apps = foldl' (\f (a, t) -> app a f t) - -apps' - :: (Ord v, Semigroup a) - => Term2 vt at ap v a - -> [Term2 vt at ap v a] - -> Term2 vt at ap v a -apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) - -iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -iff a cond t f = ABT.tm' a (If cond t f) - -ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v -ann_ e t = ABT.tm (Ann e t) - -ann :: Ord v - => a - -> Term2 vt at ap v a - -> Type vt at - -> Term2 vt at ap v a -ann a e t = ABT.tm' a (Ann e t) - --- arya: are we sure we want the two annotations to be the same? -lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a -lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) - -delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -delay a body = - ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) - -lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a -lam' a vs body = foldr (lam a) body vs - -lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a -lam'' vs body = foldr (uncurry lam) body vs - -isLam :: Term2 vt at ap v a -> Bool -isLam t = arity t > 0 - -arity :: Term2 vt at ap v a -> Int -arity (LamNamed' _ body) = 1 + arity body -arity (Ann' e _) = arity e -arity _ = 0 - -unLetRecNamedAnnotated - :: Term' vt v a - -> Maybe - (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) -unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = - Just (isTop, ann, avs `zip` bs, e) -unLetRecNamedAnnotated _ = Nothing - -letRec' - :: (Ord v, Monoid a) - => Bool - -> [(v, Term' vt v a)] - -> Term' vt v a - -> Term' vt v a -letRec' isTop bindings body = - letRec isTop - (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) - [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] - body - --- Prepend a binding to form a (bigger) let rec. Useful when --- building up a block incrementally using a right fold. --- --- For example: --- consLetRec (x = 42) "hi" --- => --- let rec x = 42 in "hi" --- --- consLetRec (x = 42) (let rec y = "hi" in (x,y)) --- => --- let rec x = 42; y = "hi" in (x,y) -consLetRec - :: Ord v - => Bool -- isTop parameter - -> a -- annotation for overall let rec - -> (a, v, Term' vt v a) -- the binding - -> Term' vt v a -- the body - -> Term' vt v a -consLetRec isTop a (ab, vb, b) body = case body of - LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body - _ -> letRec isTop a [((ab,vb),b)] body - -letRec - :: Ord v - => Bool - -> a - -> [((a, v), Term' vt v a)] - -> Term' vt v a - -> Term' vt v a -letRec _ _ [] e = e -letRec isTop a bindings e = ABT.cycle' - a - (foldr (uncurry ABT.abs' . fst) z bindings) - where z = ABT.tm' a (LetRec isTop (map snd bindings) e) - - --- | Smart constructor for let rec blocks. Each binding in the block may --- reference any other binding in the block in its body (including itself), --- and the output expression may also reference any binding in the block. -letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v -letRec_ _ [] e = e -letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) - where - z = ABT.tm (LetRec isTop (map snd bindings) e) - --- | Smart constructor for let blocks. Each binding in the block may --- reference only previous bindings in the block, not including itself. --- The output expression may reference any binding in the block. --- todo: delete me -let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v -let1_ isTop bindings e = foldr f e bindings - where - f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) - --- | annotations are applied to each nested Let expression -let1 - :: Ord v - => IsTop - -> [((a, v), Term2 vt at ap v a)] - -> Term2 vt at ap v a - -> Term2 vt at ap v a -let1 isTop bindings e = foldr f e bindings - where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) - -let1' - :: (Semigroup a, Ord v) - => IsTop - -> [(v, Term2 vt at ap v a)] - -> Term2 vt at ap v a - -> Term2 vt at ap v a -let1' isTop bindings e = foldr f e bindings - where - ann = ABT.annotation - f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) - where a = ann b <> ann body - --- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v --- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e - -unLet1 - :: Var v - => Term' vt v a - -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) -unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) -unLet1 _ = Nothing - --- | Satisfies `unLet (let' bs e) == Just (bs, e)` -unLet - :: Term2 vt at ap v a - -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) -unLet t = fixup (go t) - where - go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of - (env, t) -> ((isTop, v, b) : env, t) - go t = ([], t) - fixup ([], _) = Nothing - fixup bst = Just bst - --- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` -unLetRecNamed - :: Term2 vt at ap v a - -> Maybe - ( IsTop - , [(v, Term2 vt at ap v a)] - , Term2 vt at ap v a - ) -unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) - | length vs == length bs = Just (isTop, zip vs bs, e) -unLetRecNamed _ = Nothing - -unLetRec - :: (Monad m, Var v) - => Term2 vt at ap v a - -> Maybe - ( IsTop - , (v -> m v) - -> m - ( [(v, Term2 vt at ap v a)] - , Term2 vt at ap v a - ) - ) -unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just - ( isTop - , \freshen -> do - vs <- sequence [ freshen v | (v, _) <- bs ] - let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) - pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) - ) -unLetRec _ = Nothing - -unApps - :: Term2 vt at ap v a - -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) -unApps t = unAppsPred (t, const True) - --- Same as unApps but taking a predicate controlling whether we match on a given function argument. -unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> - Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) -unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) - where - go (App' i o) acc | pred o = go i (o:acc) - go _ [] = [] - go fn args = fn:args - -unBinaryApp :: Term2 vt at ap v a - -> Maybe (Term2 vt at ap v a, - Term2 vt at ap v a, - Term2 vt at ap v a) -unBinaryApp t = case unApps t of - Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) - _ -> Nothing - --- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" -unBinaryApps - :: Term2 vt at ap v a - -> Maybe - ( [(Term2 vt at ap v a, Term2 vt at ap v a)] - , Term2 vt at ap v a - ) -unBinaryApps t = unBinaryAppsPred (t, const True) - --- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. -unBinaryAppsPred :: (Term2 vt at ap v a - ,Term2 vt at ap v a -> Bool) - -> Maybe ([(Term2 vt at ap v a, - Term2 vt at ap v a)], - Term2 vt at ap v a) -unBinaryAppsPred (t, pred) = case unBinaryApp t of - Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of - Just (as, xLast) -> Just ((xLast, f) : as, y) - Nothing -> Just ([(x, f)], y) - _ -> Nothing - -unLams' - :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) -unLams' t = unLamsPred' (t, const True) - --- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a --- lambda extraction. -unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) -unLamsOpt' t = case unLams' t of - r@(Just _) -> r - Nothing -> Just ([], t) - --- Same as unLams', but stops at any variable named `()`, which indicates a --- delay (`'`) annotation which we want to preserve. -unLamsUntilDelay' - :: Var v - => Term2 vt at ap v a - -> Maybe ([v], Term2 vt at ap v a) -unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of - r@(Just _) -> r - Nothing -> Just ([], t) - --- Same as unLams' but taking a predicate controlling whether we match on a given binary function. -unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> - Maybe ([v], Term2 vt at ap v a) -unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of - Nothing -> Just ([v], body) - Just (vs, body) -> Just (v:vs, body) -unLamsPred' _ = Nothing - -unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) -unReqOrCtor (Constructor' r cid) = Just (r, cid) -unReqOrCtor (Request' r cid) = Just (r, cid) -unReqOrCtor _ = Nothing - --- Dependencies including referenced data and effect decls -dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference -dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) - -termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference -termDependencies = - Set.fromList - . mapMaybe - ( LD.fold - (\_typeRef -> Nothing) - ( Referent.fold - (\termRef -> Just termRef) - (\_typeConRef _i _ct -> Nothing) - ) - ) - . toList - . labeledDependencies - --- gets types from annotations and constructors -typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference -typeDependencies = - Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies - --- Gets the types to which this term contains references via patterns and --- data constructors. -constructorDependencies - :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference -constructorDependencies = - Set.unions - . generalizedDependencies (const mempty) - (const mempty) - Set.singleton - (const . Set.singleton) - Set.singleton - (const . Set.singleton) - Set.singleton - -generalizedDependencies - :: (Ord v, Ord vt, Ord r) - => (Reference -> r) - -> (Reference -> r) - -> (Reference -> r) - -> (Reference -> ConstructorId -> r) - -> (Reference -> r) - -> (Reference -> ConstructorId -> r) - -> (Reference -> r) - -> Term2 vt at ap v a - -> Set r -generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType - = Set.fromList . Writer.execWriter . ABT.visit' f where - f t@(Ref r) = Writer.tell [termRef r] $> t - f t@(TermLink r) = case r of - Referent.Ref r -> Writer.tell [termRef r] $> t - Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t - Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t - f t@(TypeLink r) = Writer.tell [typeRef r] $> t - f t@(Ann _ typ) = - Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t - f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t - f t@(Int _) = Writer.tell [literalType Type.intRef] $> t - f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t - f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t - f t@(Text _) = Writer.tell [literalType Type.textRef] $> t - f t@(List _) = Writer.tell [literalType Type.listRef] $> t - f t@(Constructor r cid) = - Writer.tell [dataType r, dataConstructor r cid] $> t - f t@(Request r cid) = - Writer.tell [effectType r, effectConstructor r cid] $> t - f t@(Match _ cases) = traverse_ goPat cases $> t - f t = pure t - goPat (MatchCase pat _ _) = - Writer.tell . toList $ Pattern.generalizedDependencies literalType - dataConstructor - dataType - effectConstructor - effectType - pat - -labeledDependencies - :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency -labeledDependencies = generalizedDependencies LD.termRef - LD.typeRef - LD.typeRef - LD.dataConstructor - LD.typeRef - LD.effectConstructor - LD.typeRef - -updateDependencies - :: Ord v - => Map Reference Reference - -> Map Reference Reference - -> Term v a - -> Term v a -updateDependencies termUpdates typeUpdates = ABT.rebuildUp go - where - -- todo: this function might need tweaking if we ever allow type replacements - -- would need to look inside pattern matching and constructor calls - go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) - go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) - go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) - go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp - go f = f - --- | If the outermost term is a function application, --- perform substitution of the argument into the body -betaReduce :: Var v => Term0 v -> Term0 v -betaReduce (App' (Lam' f) arg) = ABT.bind f arg -betaReduce e = e - -betaNormalForm :: Var v => Term0 v -> Term0 v -betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) -betaNormalForm e = e - --- x -> f x => f -etaNormalForm :: Ord v => Term0 v -> Term0 v -etaNormalForm tm = case tm of - LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body - where - step (LamNamed' v (App' f (Var' v'))) | v == v' = f - step tm = tm - _ -> tm - --- x -> f x => f as long as `x` is a variable of type `Var.Eta` -etaReduceEtaVars :: Var v => Term0 v -> Term0 v -etaReduceEtaVars tm = case tm of - LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body - where - ok v v' = v == v' && Var.typeOf v == Var.Eta - step (LamNamed' v (App' f (Var' v'))) | ok v v' = f - step tm = tm - _ -> tm - --- This converts `Reference`s it finds that are in the input `Map` --- back to free variables -unhashComponent :: forall v a. Var v - => Map Reference (Term v a) - -> Map Reference (v, Term v a) -unhashComponent m = let - usedVars = foldMap (Set.fromList . ABT.allVars) m - m' :: Map Reference (v, Term v a) - m' = evalState (Map.traverseWithKey assignVar m) usedVars where - assignVar r t = (,t) <$> ABT.freshenS (refNamed r) - unhash1 = ABT.rebuildUp' go where - go e@(Ref' r) = case Map.lookup r m' of - Nothing -> e - Just (v, _) -> var (ABT.annotation e) v - go e = e - in second unhash1 <$> m' - where - -- Variable whose name is derived from the given reference. - refNamed :: Var v => Reference -> v - refNamed ref = Var.named ("ℍ" <> Reference.toText ref) - -hashComponents - :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) -hashComponents = ReferenceUtil.hashComponents $ refId () - -hashClosedTerm :: Var v => Term v a -> Reference.Id -hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 - --- The hash for a constructor -hashConstructor' - :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference -hashConstructor' f r cid = - let --- this is a bit circuitous, but defining everything in terms of hashComponents --- ensure the hashing is always done in the same way - m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) - in case toList m of - [(r, _)] -> Reference.DerivedId r - _ -> error "unpossible" - -hashConstructor :: Reference -> ConstructorId -> Reference -hashConstructor = hashConstructor' $ constructor () - -hashRequest :: Reference -> ConstructorId -> Reference -hashRequest = hashConstructor' $ request () - -fromReferent :: Ord v - => a - -> Referent - -> Term2 vt at ap v a -fromReferent a = \case - Referent.Ref r -> ref a r - Referent.Con r i ct -> case ct of - CT.Data -> constructor a r i - CT.Effect -> request a r i - -instance Var v => Hashable1 (F v a p) where - hash1 hashCycle hash e - = let (tag, hashed, varint) = - (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) - in - case e of - -- So long as `Reference.Derived` ctors are created using the same - -- hashing function as is used here, this case ensures that references - -- are 'transparent' wrt hash and hashing is unaffected by whether - -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash - -- the same. - Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) - Ref (Reference.Derived h i n) -> Hashable.accumulate - [ tag 1 - , hashed $ Hashable.fromBytes (Hash.toBytes h) - , Hashable.Nat i - , Hashable.Nat n - ] - -- Note: start each layer with leading `1` byte, to avoid collisions - -- with types, which start each layer with leading `0`. - -- See `Hashable1 Type.F` - _ -> - Hashable.accumulate - $ tag 1 - : case e of - Nat i -> [tag 64, accumulateToken i] - Int i -> [tag 65, accumulateToken i] - Float n -> [tag 66, Hashable.Double n] - Boolean b -> [tag 67, accumulateToken b] - Text t -> [tag 68, accumulateToken t] - Char c -> [tag 69, accumulateToken c] - Blank b -> tag 1 : case b of - B.Blank -> [tag 0] - B.Recorded (B.Placeholder _ s) -> - [tag 1, Hashable.Text (Text.pack s)] - B.Recorded (B.Resolve _ s) -> - [tag 2, Hashable.Text (Text.pack s)] - Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] - Ref Reference.Derived {} -> - error "handled above, but GHC can't figure this out" - App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] - Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] - List as -> tag 5 : varint (Sequence.length as) : map - (hashed . hash) - (toList as) - Lam a -> [tag 6, hashed (hash a)] - -- note: we use `hashCycle` to ensure result is independent of - -- let binding order - LetRec _ as a -> case hashCycle as of - (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs - -- here, order is significant, so don't use hashCycle - Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] - If b t f -> - [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] - Request r n -> [tag 10, accumulateToken r, varint n] - Constructor r n -> [tag 12, accumulateToken r, varint n] - Match e branches -> - tag 13 : hashed (hash e) : concatMap h branches - where - h (MatchCase pat guard branch) = concat - [ [accumulateToken pat] - , toList (hashed . hash <$> guard) - , [hashed (hash branch)] - ] - Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] - And x y -> [tag 16, hashed $ hash x, hashed $ hash y] - Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] - TermLink r -> [tag 18, accumulateToken r] - TypeLink r -> [tag 19, accumulateToken r] - --- mostly boring serialization code below ... - -instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) -instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec - -instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where - Int x == Int y = x == y - Nat x == Nat y = x == y - Float x == Float y = x == y - Boolean x == Boolean y = x == y - Text x == Text y = x == y - Char x == Char y = x == y - Blank b == Blank q = b == q - Ref x == Ref y = x == y - TermLink x == TermLink y = x == y - TypeLink x == TypeLink y = x == y - Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 - Request r cid == Request r2 cid2 = r == r2 && cid == cid2 - Handle h b == Handle h2 b2 = h == h2 && b == b2 - App f a == App f2 a2 = f == f2 && a == a2 - Ann e t == Ann e2 t2 = e == e2 && t == t2 - List v == List v2 = v == v2 - If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 - And a b == And a2 b2 = a == a2 && b == b2 - Or a b == Or a2 b2 = a == a2 && b == b2 - Lam a == Lam b = a == b - LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 - Let _ binding body == Let _ binding2 body2 = - binding == binding2 && body == body2 - Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 - _ == _ = False - - -instance (Show v, Show a) => Show (F v a0 p a) where - showsPrec = go - where - go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n - go _ (Nat n ) = shows n - go _ (Float n ) = shows n - go _ (Boolean True ) = s "true" - go _ (Boolean False) = s "false" - go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k - go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x - go _ (Lam body ) = showParen True (s "λ " <> shows body) - go _ (List vs ) = showListWith shows (toList vs) - go _ (Blank b ) = case b of - B.Blank -> s "_" - B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) - B.Recorded (B.Resolve _ r) -> s r - go _ (Ref r) = s "Ref(" <> shows r <> s ")" - go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" - go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" - go _ (Let _ b body) = - showParen True (s "let " <> shows b <> s " in " <> shows body) - go _ (LetRec _ bs body) = showParen - True - (s "let rec" <> shows bs <> s " in " <> shows body) - go _ (Handle b body) = showParen - True - (s "handle " <> shows b <> s " in " <> shows body) - go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n - go _ (Match scrutinee cases) = showParen - True - (s "case " <> shows scrutinee <> s " of " <> shows cases) - go _ (Text s ) = shows s - go _ (Char c ) = shows c - go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n - go p (If c t f) = - showParen (p > 0) - $ s "if " - <> shows c - <> s " then " - <> shows t - <> s " else " - <> shows f - go p (And x y) = - showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y - go p (Or x y) = - showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y - (<>) = (.) - s = showString diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs deleted file mode 100644 index 8c96b37f04..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/TermEdit.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Unison.Codebase.FileCodebase.TermEdit where - -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H -import Unison.Codebase.FileCodebase.Reference (Reference) - -data TermEdit = Replace Reference Typing | Deprecate - deriving (Eq, Ord, Show) - -references :: TermEdit -> [Reference] -references (Replace r _) = [r] -references Deprecate = [] - --- Replacements with the Same type can be automatically propagated. --- Replacements with a Subtype can be automatically propagated but may result in dependents getting more general types, so requires re-inference. --- Replacements of a Different type need to be manually propagated by the programmer. -data Typing = Same | Subtype | Different - deriving (Eq, Ord, Show) - -instance Hashable Typing where - tokens Same = [H.Tag 0] - tokens Subtype = [H.Tag 1] - tokens Different = [H.Tag 2] - -instance Hashable TermEdit where - tokens (Replace r t) = [H.Tag 0] ++ H.tokens r ++ H.tokens t - tokens Deprecate = [H.Tag 1] - -toReference :: TermEdit -> Maybe Reference -toReference (Replace r _) = Just r -toReference Deprecate = Nothing - -isTypePreserving :: TermEdit -> Bool -isTypePreserving e = case e of - Replace _ Same -> True - Replace _ Subtype -> True - _ -> False - -isSame :: TermEdit -> Bool -isSame e = case e of - Replace _ Same -> True - _ -> False diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs deleted file mode 100644 index 816d910f9f..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/Type.hs +++ /dev/null @@ -1,709 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.FileCodebase.Type where - -import Unison.Prelude - -import qualified Control.Monad.Writer.Strict as Writer -import Data.Functor.Identity (runIdentity) -import Data.Monoid (Any(..)) -import Data.List.Extra (nubOrd) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) -import qualified Unison.ABT as ABT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable -import qualified Unison.Kind as K -import Unison.Codebase.FileCodebase.Reference (Reference) -import qualified Unison.Codebase.FileCodebase.Reference as Reference -import qualified Unison.Codebase.FileCodebase.Reference.Util as ReferenceUtil -import Unison.Var (Var) -import qualified Unison.Var as Var -import qualified Unison.Settings as Settings -import qualified Unison.Names.ResolutionResult as Names -import qualified Unison.Name as Name -import qualified Unison.Util.List as List - --- | Base functor for types in the Unison language -data F a - = Ref Reference - | Arrow a a - | Ann a K.Kind - | App a a - | Effect a a - | Effects [a] - | Forall a - | IntroOuter a -- binder like ∀, used to introduce variables that are - -- bound by outer type signatures, to support scoped type - -- variables - deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) - -instance Eq1 F where (==#) = (==) -instance Ord1 F where compare1 = compare -instance Show1 F where showsPrec1 = showsPrec - --- | Types are represented as ABTs over the base functor F, with variables in `v` -type Type v a = ABT.Term F v a - -wrapV :: Ord v => Type v a -> Type (ABT.V v) a -wrapV = ABT.vmap ABT.Bound - -freeVars :: Type v a -> Set v -freeVars = ABT.freeVars - -bindExternal - :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a -bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] - -bindNames - :: Var v - => Set v - -> Map Name.Name Reference - -> Type v a - -> Names.ResolutionResult v a (Type v a) -bindNames keepFree ns t = let - fvs = ABT.freeVarOccurrences keepFree t - rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] - ok (v, _a, Just r) = pure (v, r) - ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) - in List.validate ok rs <&> \es -> bindExternal es t - -newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq - -instance (Show v) => Show (Monotype v a) where - show = show . getPolytype - --- Smart constructor which checks if a `Type` has no `Forall` quantifiers. -monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) -monotype t = Monotype <$> ABT.visit isMono t where - isMono (Forall' _) = Just Nothing - isMono _ = Nothing - -arity :: Type v a -> Int -arity (ForallNamed' _ body) = arity body -arity (Arrow' _ o) = 1 + arity o -arity (Ann' a _) = arity a -arity _ = 0 - --- some smart patterns -pattern Ref' r <- ABT.Tm' (Ref r) -pattern Arrow' i o <- ABT.Tm' (Arrow i o) -pattern Arrow'' i es o <- Arrow' i (Effect'' es o) -pattern Arrows' spine <- (unArrows -> Just spine) -pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) -pattern Ann' t k <- ABT.Tm' (Ann t k) -pattern App' f x <- ABT.Tm' (App f x) -pattern Apps' f args <- (unApps -> Just (f, args)) -pattern Pure' t <- (unPure -> Just t) -pattern Effects' es <- ABT.Tm' (Effects es) --- Effect1' must match at least one effect -pattern Effect1' e t <- ABT.Tm' (Effect e t) -pattern Effect' es t <- (unEffects1 -> Just (es, t)) -pattern Effect'' es t <- (unEffect0 -> (es, t)) --- Effect0' may match zero effects -pattern Effect0' es t <- (unEffect0 -> (es, t)) -pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) -pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) -pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) -pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) -pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) -pattern Var' v <- ABT.Var' v -pattern Cycle' xs t <- ABT.Cycle' xs t -pattern Abs' subst <- ABT.Abs' subst - -unPure :: Ord v => Type v a -> Maybe (Type v a) -unPure (Effect'' [] t) = Just t -unPure (Effect'' _ _) = Nothing -unPure t = Just t - -unArrows :: Type v a -> Maybe [Type v a] -unArrows t = - case go t of [_] -> Nothing; l -> Just l - where go (Arrow' i o) = i : go o - go o = [o] - -unEffectfulArrows - :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) -unEffectfulArrows t = case t of - Arrow' i o -> Just (i, go o) - _ -> Nothing - where - go (Effect1' (Effects' es) (Arrow' i o)) = - (Just $ es >>= flattenEffects, i) : go o - go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] - go (Arrow' i o) = (Nothing, i) : go o - go t = [(Nothing, t)] - -unApps :: Type v a -> Maybe (Type v a, [Type v a]) -unApps t = case go t [] of - [] -> Nothing - [ _ ] -> Nothing - f : args -> Just (f, args) - where - go (App' i o) acc = go i (o : acc) - go fn args = fn : args - -unIntroOuters :: Type v a -> Maybe ([v], Type v a) -unIntroOuters t = go t [] - where go (IntroOuterNamed' v body) vs = go body (v:vs) - go _body [] = Nothing - go body vs = Just (reverse vs, body) - --- Most code doesn't care about `introOuter` binders and is fine dealing with the --- these outer variable references as free variables. This function strips out --- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. -stripIntroOuters :: Type v a -> Type v a -stripIntroOuters t = case unIntroOuters t of - Just (_, t) -> t - Nothing -> t - -unForalls :: Type v a -> Maybe ([v], Type v a) -unForalls t = go t [] - where go (ForallNamed' v body) vs = go body (v:vs) - go _body [] = Nothing - go body vs = Just(reverse vs, body) - -unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) -unEffect0 (Effect1' e a) = (flattenEffects e, a) -unEffect0 t = ([], t) - -unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) -unEffects1 (Effect1' (Effects' es) a) = Just (es, a) -unEffects1 _ = Nothing - --- | True if the given type is a function, possibly quantified -isArrow :: ABT.Var v => Type v a -> Bool -isArrow (ForallNamed' _ t) = isArrow t -isArrow (Arrow' _ _) = True -isArrow _ = False - --- some smart constructors - -ref :: Ord v => a -> Reference -> Type v a -ref a = ABT.tm' a . Ref - -refId :: Ord v => a -> Reference.Id -> Type v a -refId a = ref a . Reference.DerivedId - -termLink :: Ord v => a -> Type v a -termLink a = ABT.tm' a . Ref $ termLinkRef - -typeLink :: Ord v => a -> Type v a -typeLink a = ABT.tm' a . Ref $ typeLinkRef - -derivedBase32Hex :: Ord v => Reference -> a -> Type v a -derivedBase32Hex r a = ref a r - -intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference -intRef = Reference.Builtin "Int" -natRef = Reference.Builtin "Nat" -floatRef = Reference.Builtin "Float" -booleanRef = Reference.Builtin "Boolean" -textRef = Reference.Builtin "Text" -charRef = Reference.Builtin "Char" -listRef = Reference.Builtin "Sequence" -bytesRef = Reference.Builtin "Bytes" -effectRef = Reference.Builtin "Effect" -termLinkRef = Reference.Builtin "Link.Term" -typeLinkRef = Reference.Builtin "Link.Type" - -builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference -builtinIORef = Reference.Builtin "IO" -fileHandleRef = Reference.Builtin "Handle" -filePathRef = Reference.Builtin "FilePath" -threadIdRef = Reference.Builtin "ThreadId" -socketRef = Reference.Builtin "Socket" - -mvarRef, tvarRef :: Reference -mvarRef = Reference.Builtin "MVar" -tvarRef = Reference.Builtin "TVar" - -tlsRef :: Reference -tlsRef = Reference.Builtin "Tls" - -stmRef :: Reference -stmRef = Reference.Builtin "STM" - -tlsClientConfigRef :: Reference -tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" - -tlsServerConfigRef :: Reference -tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" - -tlsSignedCertRef :: Reference -tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" - -tlsPrivateKeyRef :: Reference -tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" - -tlsCipherRef :: Reference -tlsCipherRef = Reference.Builtin "Tls.Cipher" - -tlsVersionRef :: Reference -tlsVersionRef = Reference.Builtin "Tls.Version" - -hashAlgorithmRef :: Reference -hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" - -codeRef, valueRef :: Reference -codeRef = Reference.Builtin "Code" -valueRef = Reference.Builtin "Value" - -anyRef :: Reference -anyRef = Reference.Builtin "Any" - -any :: Ord v => a -> Type v a -any a = ref a anyRef - -builtin :: Ord v => a -> Text -> Type v a -builtin a = ref a . Reference.Builtin - -int :: Ord v => a -> Type v a -int a = ref a intRef - -nat :: Ord v => a -> Type v a -nat a = ref a natRef - -float :: Ord v => a -> Type v a -float a = ref a floatRef - -boolean :: Ord v => a -> Type v a -boolean a = ref a booleanRef - -text :: Ord v => a -> Type v a -text a = ref a textRef - -char :: Ord v => a -> Type v a -char a = ref a charRef - -fileHandle :: Ord v => a -> Type v a -fileHandle a = ref a fileHandleRef - -threadId :: Ord v => a -> Type v a -threadId a = ref a threadIdRef - -builtinIO :: Ord v => a -> Type v a -builtinIO a = ref a builtinIORef - -socket :: Ord v => a -> Type v a -socket a = ref a socketRef - -list :: Ord v => a -> Type v a -list a = ref a listRef - -bytes :: Ord v => a -> Type v a -bytes a = ref a bytesRef - -effectType :: Ord v => a -> Type v a -effectType a = ref a $ effectRef - -code, value :: Ord v => a -> Type v a -code a = ref a codeRef -value a = ref a valueRef - -app :: Ord v => a -> Type v a -> Type v a -> Type v a -app a f arg = ABT.tm' a (App f arg) - --- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one --- meant for `app (f x) y` -apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a -apps = foldl' go where go f (a, t) = app a f t - -app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a -app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg - -apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a -apps' = foldl app' - -arrow :: Ord v => a -> Type v a -> Type v a -> Type v a -arrow a i o = ABT.tm' a (Arrow i o) - -arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a -arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o - -ann :: Ord v => a -> Type v a -> K.Kind -> Type v a -ann a e t = ABT.tm' a (Ann e t) - -forall :: Ord v => a -> v -> Type v a -> Type v a -forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) - -introOuter :: Ord v => a -> v -> Type v a -> Type v a -introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) - -iff :: Var v => Type v () -iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a - where aa = Var.named "a" - a = var () aa - f x = ((), x) - -iff' :: Var v => a -> Type v a -iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a - where aa = Var.named "a" - a = var loc aa - f x = (loc, x) - -iff2 :: Var v => a -> Type v a -iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a - where aa = Var.named "a" - a = var loc aa - f x = (loc, x) - -andor :: Ord v => Type v () -andor = arrows (f <$> [boolean(), boolean()]) $ boolean() - where f x = ((), x) - -andor' :: Ord v => a -> Type v a -andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a - where f x = (a, x) - -var :: Ord v => a -> v -> Type v a -var = ABT.annotatedVar - -v' :: Var v => Text -> Type v () -v' s = ABT.var (Var.named s) - --- Like `v'`, but creates an annotated variable given an annotation -av' :: Var v => a -> Text -> Type v a -av' a s = ABT.annotatedVar a (Var.named s) - -forall' :: Var v => a -> [Text] -> Type v a -> Type v a -forall' a vs body = foldr (forall a) body (Var.named <$> vs) - -foralls :: Ord v => a -> [v] -> Type v a -> Type v a -foralls a vs body = foldr (forall a) body vs - --- Note: `a -> b -> c` parses as `a -> (b -> c)` --- the annotation associated with `b` will be the annotation for the `b -> c` --- node -arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a -arrows ts result = foldr go result ts where - go = uncurry arrow - --- The types of effectful computations -effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a -effect a es (Effect1' fs t) = - let es' = (es >>= flattenEffects) ++ flattenEffects fs - in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) -effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) - -effects :: Ord v => a -> [Type v a] -> Type v a -effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) - -effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a -effect1 a es (Effect1' fs t) = - let es' = flattenEffects es ++ flattenEffects fs - in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) -effect1 a es t = ABT.tm' a (Effect es t) - -flattenEffects :: Type v a -> [Type v a] -flattenEffects (Effects' es) = es >>= flattenEffects -flattenEffects es = [es] - --- The types of first-class effect values --- which get deconstructed in effect handlers. -effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a -effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] - --- Strips effects from a type. E.g. `{e} a` becomes `a`. -stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) -stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) -stripEffect t = ([], t) - --- The type of the flipped function application operator: --- `(a -> (a -> b) -> b)` -flipApply :: Var v => Type v () -> Type v () -flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) - where b = ABT.fresh t (Var.named "b") - -generalize' :: Var v => Var.Type -> Type v a -> Type v a -generalize' k t = generalize vsk t where - vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] - --- | Bind the given variables with an outer `forall`, if they are used in `t`. -generalize :: Ord v => [v] -> Type v a -> Type v a -generalize vs t = foldr f t vs - where - f v t = - if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t - -unforall :: Type v a -> Type v a -unforall (ForallsNamed' _ t) = t -unforall t = t - -unforall' :: Type v a -> ([v], Type v a) -unforall' (ForallsNamed' vs t) = (vs, t) -unforall' t = ([], t) - -dependencies :: Ord v => Type v a -> Set Reference -dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t - where f t@(Ref r) = Writer.tell [r] $> t - f t = pure t - -updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a -updateDependencies typeUpdates = ABT.rebuildUp go - where - go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) - go f = f - -usesEffects :: Ord v => Type v a -> Bool -usesEffects t = getAny . getConst $ ABT.visit go t where - go (Effect1' _ _) = Just (Const (Any True)) - go _ = Nothing - --- Returns free effect variables in the given type, for instance, in: --- --- ∀ e3 . a ->{e,e2} b ->{e3} c --- --- This function would return the set {e, e2}, but not `e3` since `e3` --- is bound by the enclosing forall. -freeEffectVars :: Ord v => Type v a -> Set v -freeEffectVars t = - Set.fromList . join . runIdentity $ - ABT.foreachSubterm go (snd <$> ABT.annotateBound t) - where - go t@(Effects' es) = - let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] - in pure . Set.toList $ frees `Set.difference` ABT.annotation t - go t@(Effect1' e _) = - let frees = Set.fromList [ v | Var' v <- flattenEffects e ] - in pure . Set.toList $ frees `Set.difference` ABT.annotation t - go _ = pure [] - --- Converts all unadorned arrows in a type to have fresh --- existential ability requirements. For example: --- --- (a -> b) -> [a] -> [b] --- --- Becomes --- --- (a ->{e1} b) ->{e2} [a] ->{e3} [b] -existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) -existentializeArrows newVar t = ABT.visit go t - where - go t@(Arrow' a b) = case b of - -- If an arrow already has attached abilities, - -- leave it alone. Ex: `a ->{e} b` is kept as is. - Effect1' _ _ -> Just $ do - a <- existentializeArrows newVar a - b <- existentializeArrows newVar b - pure $ arrow (ABT.annotation t) a b - -- For unadorned arrows, make up a fresh variable. - -- So `a -> b` becomes `a ->{e} b`, using the - -- `newVar` variable generator. - _ -> Just $ do - e <- newVar - a <- existentializeArrows newVar a - b <- existentializeArrows newVar b - let ann = ABT.annotation t - pure $ arrow ann a (effect ann [var ann e] b) - go _ = Nothing - -purifyArrows :: (Ord v) => Type v a -> Type v a -purifyArrows = ABT.visitPure go - where - go t@(Arrow' a b) = case b of - Effect1' _ _ -> Nothing - _ -> Just $ arrow ann a (effect ann [] b) - where ann = ABT.annotation t - go _ = Nothing - --- Remove free effect variables from the type that are in the set -removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a -removeEffectVars removals t = - let z = effects () [] - t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t - -- leave explicitly empty `{}` alone - removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) - removeEmpty t@(Effect1' e v) = - case flattenEffects e of - [] -> Just (ABT.visitPure removeEmpty v) - es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) - removeEmpty t@(Effects' es) = - Just $ effects (ABT.annotation t) (es >>= flattenEffects) - removeEmpty _ = Nothing - in ABT.visitPure removeEmpty t' - --- Remove all effect variables from the type. --- Used for type-based search, we apply this transformation to both the --- indexed type and the query type, so the user can supply `a -> b` that will --- match `a ->{e} b` (but not `a ->{IO} b`). -removeAllEffectVars :: ABT.Var v => Type v a -> Type v a -removeAllEffectVars t = let - allEffectVars = foldMap go (ABT.subterms t) - go (Effects' vs) = Set.fromList [ v | Var' v <- vs] - go (Effect1' (Var' v) _) = Set.singleton v - go _ = mempty - (vs, tu) = unforall' t - in generalize vs (removeEffectVars allEffectVars tu) - -removePureEffects :: ABT.Var v => Type v a -> Type v a -removePureEffects t | not Settings.removePureEffects = t - | otherwise = - generalize vs $ removeEffectVars (Set.filter isPure fvs) tu - where - (vs, tu) = unforall' t - fvs = freeEffectVars tu `Set.difference` ABT.freeVars t - -- If an effect variable is mentioned only once, it is on - -- an arrow `a ->{e} b`. Generalizing this to - -- `∀ e . a ->{e} b` gives us the pure arrow `a -> b`. - isPure v = ABT.occurrences v tu <= 1 - -editFunctionResult - :: forall v a - . Ord v - => (Type v a -> Type v a) - -> Type v a - -> Type v a -editFunctionResult f = go - where - go :: Type v a -> Type v a - go (ABT.Term s a t) = case t of - ABT.Tm (Forall t) -> - (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t - ABT.Tm (Arrow i o) -> - (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o - ABT.Abs v r -> - (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r - _ -> f (ABT.Term s a t) - -functionResult :: Type v a -> Maybe (Type v a) -functionResult = go False - where - go inArr (ForallNamed' _ body) = go inArr body - go _inArr (Arrow' _i o ) = go True o - go inArr t = if inArr then Just t else Nothing - - --- | Bind all free variables (not in `except`) that start with a lowercase --- letter and are unqualified with an outer `forall`. --- `a -> a` becomes `∀ a . a -> a` --- `B -> B` becomes `B -> B` (not changed) --- `.foo -> .foo` becomes `.foo -> .foo` (not changed) --- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) -generalizeLowercase :: Var v => Set v -> Type v a -> Type v a -generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars - where - vars = - [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] - --- Convert all free variables in `allowed` to variables bound by an `introOuter`. -freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a -freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars - where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed - --- | This function removes all variable shadowing from the types and reduces --- fresh ids to the minimum possible to avoid ambiguity. Useful when showing --- two different types. -cleanupVars :: Var v => [Type v a] -> [Type v a] -cleanupVars ts | not Settings.cleanupTypes = ts -cleanupVars ts = let - changedVars = cleanupVarsMap ts - in cleanupVars1' changedVars <$> ts - --- Compute a variable replacement map from a collection of types, which --- can be passed to `cleanupVars1'`. This is used to cleanup variable ids --- for multiple related types, like when reporting a type error. -cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v -cleanupVarsMap ts = let - varsByName = foldl' step Map.empty (ts >>= ABT.allVars) - step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m - changedVars = Map.fromList [ (v, Var.freshenId i v) - | (_, vs) <- Map.toList varsByName - , (v,i) <- nubOrd vs `zip` [0..]] - in changedVars - -cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a -cleanupVars1' = ABT.changeVars - --- | This function removes all variable shadowing from the type and reduces --- fresh ids to the minimum possible to avoid ambiguity. -cleanupVars1 :: Var v => Type v a -> Type v a -cleanupVars1 t | not Settings.cleanupTypes = t -cleanupVars1 t = let [t'] = cleanupVars [t] in t' - --- This removes duplicates and normalizes the order of ability lists -cleanupAbilityLists :: Var v => Type v a -> Type v a -cleanupAbilityLists = ABT.visitPure go - where - -- leave explicitly empty `{}` alone - go (Effect1' (Effects' []) _v) = Nothing - go t@(Effect1' e v) = - let es = Set.toList . Set.fromList $ flattenEffects e - in case es of - [] -> Just (ABT.visitPure go v) - _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) - go _ = Nothing - -cleanups :: Var v => [Type v a] -> [Type v a] -cleanups ts = cleanupVars $ map cleanupAbilityLists ts - -cleanup :: Var v => Type v a -> Type v a -cleanup t | not Settings.cleanupTypes = t -cleanup t = cleanupVars1 . cleanupAbilityLists $ t - -toReference :: (ABT.Var v, Show v) => Type v a -> Reference -toReference (Ref' r) = r --- a bit of normalization - any unused type parameters aren't part of the hash -toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body -toReference t = Reference.Derived (ABT.hash t) 0 1 - -toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference -toReferenceMentions ty = - let (vs, _) = unforall' ty - gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty - in Set.fromList $ toReference . gen <$> ABT.subterms ty - -hashComponents - :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) -hashComponents = ReferenceUtil.hashComponents $ refId () - -instance Hashable1 F where - hash1 hashCycle hash e = - let - (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `0` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 0 : case e of - Ref r -> [tag 0, Hashable.accumulateToken r] - Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] - App a b -> [tag 2, hashed (hash a), hashed (hash b) ] - Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] - -- Example: - -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as - -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from - -- c) {Remote, Abort} (() -> {Abort} ()) - Effects es -> let - (hs, _) = hashCycle es - in tag 4 : map hashed hs - Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] - Forall a -> [tag 6, hashed (hash a)] - IntroOuter a -> [tag 7, hashed (hash a)] - -instance Show a => Show (F a) where - showsPrec = go where - go _ (Ref r) = shows r - go p (Arrow i o) = - showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o - go p (Ann t k) = - showParen (p > 1) $ shows t <> s":" <> shows k - go p (App f x) = - showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x - go p (Effects es) = showParen (p > 0) $ - s"{" <> shows es <> s"}" - go p (Effect e t) = showParen (p > 0) $ - showParen True $ shows e <> s" " <> showsPrec p t - go p (Forall body) = case p of - 0 -> showsPrec p body - _ -> showParen True $ s"∀ " <> shows body - go p (IntroOuter body) = case p of - 0 -> showsPrec p body - _ -> showParen True $ s"outer " <> shows body - (<>) = (.) - s = showString - diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs deleted file mode 100644 index 7fe1e49115..0000000000 --- a/parser-typechecker/src/Unison/Codebase/FileCodebase/TypeEdit.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Unison.Codebase.FileCodebase.TypeEdit where - -import Unison.Codebase.FileCodebase.Reference (Reference) -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H - -data TypeEdit = Replace Reference | Deprecate - deriving (Eq, Ord, Show) - -references :: TypeEdit -> [Reference] -references (Replace r) = [r] -references Deprecate = [] - -instance Hashable TypeEdit where - tokens (Replace r) = H.Tag 0 : H.tokens r - tokens Deprecate = [H.Tag 1] - -toReference :: TypeEdit -> Maybe Reference -toReference (Replace r) = Just r -toReference Deprecate = Nothing diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 406c503474..c183d4677c 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -21,7 +21,6 @@ import Unison.Term (Term) import Unison.Type (Type) import qualified Unison.WatchKind as WK import Unison.Codebase.GitError (GitProtocolError, GitCodebaseError) -import Unison.Codebase.FileCodebase.Codebase (GitFileCodebaseError) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError) type SyncToDir m = @@ -96,6 +95,5 @@ data GetRootBranchError data GitError = GitProtocolError GitProtocolError | GitCodebaseError (GitCodebaseError Branch.Hash) - | GitFileCodebaseError GitFileCodebaseError | GitSqliteCodebaseError GitSqliteCodebaseError deriving Show \ No newline at end of file diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index 4a88083179..a691ff8494 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -1282,12 +1282,6 @@ debugNumberedArgs = InputPattern "debug.numberedArgs" [] [] "Dump the contents of the numbered args state." (const $ Right Input.DebugNumberedArgsI) -debugBranchHistory :: InputPattern -debugBranchHistory = InputPattern "debug.history" [] - [(Optional, noCompletions)] - "Dump codebase history, compatible with bit-booster.com/graph.html" - (const $ Right Input.DebugBranchHistoryI) - debugFileHashes :: InputPattern debugFileHashes = InputPattern "debug.file" [] [] "View details about the most recent succesfully typechecked file." @@ -1429,7 +1423,6 @@ validInputs = , mergeIOBuiltins , dependents, dependencies , debugNumberedArgs - , debugBranchHistory , debugFileHashes , debugDumpNamespace , debugClearWatchCache diff --git a/parser-typechecker/tests/Unison/Test/Ucm.hs b/parser-typechecker/tests/Unison/Test/Ucm.hs index 9bf002600a..8117ff31e9 100644 --- a/parser-typechecker/tests/Unison/Test/Ucm.hs +++ b/parser-typechecker/tests/Unison/Test/Ucm.hs @@ -22,7 +22,6 @@ import qualified System.IO.Temp as Temp import U.Util.String (stripMargin) import Unison.Codebase (CodebasePath) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Init as Codebase.Init import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 71e6b4bbc4..802bbe523f 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -56,26 +56,6 @@ library Unison.Codebase.Editor.UriParser Unison.Codebase.Editor.VersionParser Unison.Codebase.Execute - Unison.Codebase.FileCodebase - Unison.Codebase.FileCodebase.Branch - Unison.Codebase.FileCodebase.Branch.Dependencies - Unison.Codebase.FileCodebase.Codebase - Unison.Codebase.FileCodebase.Common - Unison.Codebase.FileCodebase.DataDeclaration - Unison.Codebase.FileCodebase.Init - Unison.Codebase.FileCodebase.LabeledDependency - Unison.Codebase.FileCodebase.Metadata - Unison.Codebase.FileCodebase.Patch - Unison.Codebase.FileCodebase.Pattern - Unison.Codebase.FileCodebase.Reference - Unison.Codebase.FileCodebase.Reference.Util - Unison.Codebase.FileCodebase.Referent - Unison.Codebase.FileCodebase.Serialization.V1 - Unison.Codebase.FileCodebase.SlimCopyRegenerateIndex - Unison.Codebase.FileCodebase.Term - Unison.Codebase.FileCodebase.TermEdit - Unison.Codebase.FileCodebase.Type - Unison.Codebase.FileCodebase.TypeEdit Unison.Codebase.GitError Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 361b37feed..e6c4e34b20 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -37,7 +37,6 @@ import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) -import qualified Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR @@ -383,7 +382,7 @@ getCodebaseOrExit cbFormat mdir = do prettyDir = P.string <$> canonicalizePath dir PT.putPrettyLn' =<< case cbFormat of V1 -> sayNoCodebase - V2 -> FC.openCodebase dir >>= \case + V2 -> undefined >>= \case Left {} -> sayNoCodebase Right {} -> suggestUpgrade Exit.exitFailure From 9d6d007c585f600f446847fedbd993d697297515 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 15:31:27 -0400 Subject: [PATCH 019/148] cleanup unused code warnings --- parser-typechecker/src/Unison/Codebase.hs | 5 - .../src/Unison/Codebase/Branch.hs | 21 - .../src/Unison/Codebase/Branch/Merge.hs | 671 +----------------- .../src/Unison/Codebase/Branch/Names.hs | 65 +- .../src/Unison/Codebase/CodeLookup.hs | 32 +- .../src/Unison/Codebase/CodeLookup/Util.hs | 4 - .../src/Unison/Codebase/Editor/Command.hs | 1 - .../src/Unison/Codebase/MainTerm.hs | 1 - .../src/Unison/Codebase/Path.hs | 187 +---- .../src/Unison/Codebase/Path/Parse.hs | 105 +-- .../src/Unison/Codebase/Runtime.hs | 29 +- .../Codebase/SqliteCodebase/Conversions.hs | 2 - parser-typechecker/src/Unison/FileParser.hs | 9 +- parser-typechecker/src/Unison/FileParsers.hs | 1 - parser-typechecker/src/Unison/Parser.hs | 1 - .../src/Unison/PrettyPrintEnv.hs | 14 - .../src/Unison/PrettyPrintEnv/Names.hs | 130 +--- .../src/Unison/PrettyPrintEnv/Util.hs | 24 +- parser-typechecker/src/Unison/PrintError.hs | 11 +- .../src/Unison/Server/Backend.hs | 1 - parser-typechecker/src/Unison/UnisonFile.hs | 166 +---- .../src/Unison/UnisonFile/Env.hs | 3 - .../src/Unison/UnisonFile/Names.hs | 18 +- unison-core/src/Unison/DataDeclaration.hs | 125 +--- unison-core/src/Unison/NameSegment.hs | 2 - unison-core/src/Unison/Referent.hs | 26 - unison-core/src/Unison/Type/Names.hs | 16 +- 27 files changed, 127 insertions(+), 1543 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 016f8499a7..f866739581 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -30,12 +30,8 @@ import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), SyncToDir, import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.Prelude import qualified Unison.UnisonFile as UF -import Control.Lens ((%=), _1, _2) import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.State (State, evalState, get) -import Data.Bifunctor (bimap) import Control.Error.Util (hush) -import Data.Maybe as Maybe import Data.List as List import qualified Data.Map as Map import Unison.Symbol (Symbol) @@ -58,7 +54,6 @@ import Unison.Typechecker.TypeLookup (TypeLookup(TypeLookup)) import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Branch (Branch) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -import Control.Monad.Except (runExceptT, ExceptT (ExceptT)) import Unison.Codebase.SyncMode (SyncMode) import qualified Unison.Codebase.GitError as GitError import U.Util.Timing (time) diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 2dc6d26492..0143a1abda 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -111,7 +111,6 @@ import qualified U.Util.Cache as Cache import qualified Unison.Util.Relation as R import Unison.Util.Relation ( Relation ) import qualified Unison.Util.Relation4 as R4 -import Unison.Util.Map ( unionWithM ) import qualified Unison.Util.Star3 as Star3 import qualified Unison.Util.List as List @@ -503,30 +502,10 @@ uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) uncons (Branch b) = go <$> Causal.uncons b where go = over (_Just . _2) Branch --- Modify the branch0 at the head of at `path` with `f`, --- after creating it if necessary. Preserves history. -stepAt :: forall m. Applicative m - => Path - -> (Branch0 m -> Branch0 m) - -> Branch m -> Branch m -stepAt p f = modifyAt p g where - g :: Branch m -> Branch m - g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b - stepManyAt :: (Monad m, Foldable f) => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m stepManyAt actions = step (stepManyAt0 actions) --- Modify the branch0 at the head of at `path` with `f`, --- after creating it if necessary. Preserves history. -stepAtM :: forall n m. (Functor n, Applicative m) - => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) -stepAtM p f = modifyAtM p g where - g :: Branch m -> n (Branch m) - g (Branch b) = do - b0' <- f (Causal.head b) - pure $ Branch . Causal.consDistinct b0' $ b - stepManyAtM :: (Monad m, Monad n, Foldable f) => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) stepManyAtM actions = stepM (stepManyAt0M actions) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs index 12e4c08e7a..99e9462ae4 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Merge.hs @@ -12,195 +12,19 @@ module Unison.Codebase.Branch.Merge import Unison.Prelude hiding (empty) import Unison.Codebase.Branch -import Prelude hiding (head,read,subtract) - -import Control.Lens hiding ( children, cons, transform, uncons ) -import qualified Control.Monad.State as State -import Control.Monad.State ( StateT ) -import Data.Bifunctor ( second ) -import qualified Data.Map as Map -import qualified Data.Map.Merge.Lazy as Map -import qualified Data.Set as Set -import qualified Unison.Codebase.Patch as Patch -import Unison.Codebase.Patch ( Patch ) -import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Causal ( Causal - , pattern RawOne - , pattern RawCons - , pattern RawMerge - ) -import Unison.Codebase.Path ( Path(..) ) -import qualified Unison.Codebase.Path as Path -import Unison.NameSegment ( NameSegment ) -import qualified Unison.NameSegment as NameSegment -import qualified Unison.Codebase.Metadata as Metadata -import qualified Unison.Hash as Hash -import Unison.Hashable ( Hashable ) -import qualified Unison.Hashable as H -import Unison.Name ( Name(..) ) -import qualified Unison.Name as Name -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) - -import qualified U.Util.Cache as Cache -import qualified Unison.Util.Relation as R -import Unison.Util.Relation ( Relation ) -import qualified Unison.Util.Relation4 as R4 -import Unison.Util.Map ( unionWithM ) -import qualified Unison.Util.Star3 as Star3 - --- -- | 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) - --- type Hash = Causal.RawHash Raw --- type EditHash = Hash.Hash - --- 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` --- , deepTerms :: Relation Referent Name --- , deepTypes :: Relation Reference Name --- , deepTermMetadata :: Metadata.R4 Referent Name --- , deepTypeMetadata :: Metadata.R4 Reference Name --- , deepPaths :: Set Path --- , deepEdits :: Map Name EditHash --- } - --- -- Represents a shallow diff of a Branch0. --- -- Each of these `Star`s contain metadata as well, so an entry in --- -- `added` or `removed` could be an update to the metadata. --- data BranchDiff = BranchDiff --- { addedTerms :: Star Referent NameSegment --- , removedTerms :: Star Referent NameSegment --- , addedTypes :: Star Reference NameSegment --- , removedTypes :: Star Reference NameSegment --- , changedPatches :: Map NameSegment Patch.PatchDiff --- } deriving (Eq, Ord, Show) - --- instance Semigroup BranchDiff where --- left <> right = BranchDiff --- { addedTerms = addedTerms left <> addedTerms right --- , removedTerms = removedTerms left <> removedTerms right --- , addedTypes = addedTypes left <> addedTypes right --- , removedTypes = removedTypes left <> removedTypes right --- , changedPatches = --- Map.unionWith (<>) (changedPatches left) (changedPatches right) --- } - --- instance Monoid BranchDiff where --- mappend = (<>) --- mempty = BranchDiff mempty mempty mempty mempty mempty - --- -- The raw Branch --- data Raw = Raw --- { _termsR :: Star Referent NameSegment --- , _typesR :: Star Reference NameSegment --- , _childrenR :: Map NameSegment Hash --- , _editsR :: Map NameSegment EditHash --- } - --- makeLenses ''Branch --- makeLensesFor [("_edits", "edits")] ''Branch0 - --- terms :: Lens' (Branch0 m) (Star Referent NameSegment) --- terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) - --- types :: Lens' (Branch0 m) (Star Reference NameSegment) --- types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) - --- children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) --- children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) - --- -- creates a Branch0 from the primary fields and derives the others. --- branch0 :: Metadata.Star Referent NameSegment --- -> Metadata.Star Reference NameSegment --- -> Map NameSegment (Branch m) --- -> Map NameSegment (EditHash, m Patch) --- -> Branch0 m --- branch0 terms types children edits = --- Branch0 terms types children edits --- deepTerms' deepTypes' --- deepTermMetadata' deepTypeMetadata' --- deepPaths' deepEdits' --- where --- nameSegToName = Name.unsafeFromText . NameSegment.toText --- deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms --- <> foldMap go (Map.toList children) --- where --- go (nameSegToName -> n, b) = --- R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic --- deepTypes' = (R.mapRan nameSegToName . Star3.d1) types --- <> foldMap go (Map.toList children) --- where --- go (nameSegToName -> n, b) = --- R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic --- deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) --- <> foldMap go (Map.toList children) --- where --- go (nameSegToName -> n, b) = --- R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) --- deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) --- <> foldMap go (Map.toList children) --- where --- go (nameSegToName -> n, b) = --- R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) --- deepPaths' = Set.map Path.singleton (Map.keysSet children) --- <> foldMap go (Map.toList children) --- where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) --- deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) --- <> foldMap go (Map.toList children) --- where --- go (nameSeg, b) = --- Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b - --- head :: Branch m -> Branch0 m --- head (Branch c) = Causal.head c - --- headHash :: Branch m -> Hash --- headHash (Branch c) = Causal.currentHash c - --- -- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) --- -- deepEdits' b = go id b where --- -- -- can change this to an actual prefix once Name is a [NameSegment] --- -- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) --- -- go addPrefix Branch0{..} = --- -- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits --- -- <> foldMap f (Map.toList _children) --- -- where --- -- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) --- -- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) +import Prelude hiding (head, read, subtract) +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.Patch (Patch) +import qualified Unison.Codebase.Patch as Patch +import qualified Unison.Hashable as H +import Unison.Util.Map (unionWithM) +import qualified Unison.Util.Relation as R +import qualified Unison.Util.Star3 as Star3 data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) -merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) -merge = merge' RegularMerge - --- -- Discards the history of a Branch0's children, recursively --- discardHistory0 :: Applicative m => Branch0 m -> Branch0 m --- discardHistory0 = over children (fmap tweak) where --- tweak b = cons (discardHistory0 (head b)) empty - -merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) -merge' = merge'' lca - merge'' :: forall m . Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator -> MergeMode @@ -262,18 +86,6 @@ merge'' lca mode (Branch x) (Branch y) = } pure (H.accumulate' np, pure np) --- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- -- It's defined as: lca b1 b2 == Just b1 --- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) --- -> Branch m -> Branch m -> m Bool --- before' lca (Branch x) (Branch y) = Causal.before' lca' x y --- where --- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - --- `before b1 b2` is true if `b2` incorporates all of `b1` -before :: Monad m => Branch m -> Branch m -> m Bool -before (Branch b1) (Branch b2) = Causal.before b1 b2 - merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) merge0 lca mode b1 b2 = do @@ -291,466 +103,3 @@ merge0 lca mode b1 b2 = do e2 <- m2 let e3 = e1 <> e2 pure (H.accumulate' e3, pure e3) - --- pattern Hash h = Causal.RawHash h - --- -- toList0 :: Branch0 m -> [(Path, Branch0 m)] --- -- toList0 = go Path.empty where --- -- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> --- -- go (Path.snoc p seg) (head cb) )) - --- -- printDebugPaths :: Branch m -> String --- -- printDebugPaths = unlines . map show . Set.toList . debugPaths - --- -- debugPaths :: Branch m -> Set (Path, Hash) --- -- debugPaths = go Path.empty where --- -- go p b = Set.insert (p, headHash b) . Set.unions $ --- -- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] - --- -- data Target = TargetType | TargetTerm | TargetBranch --- -- deriving (Eq, Ord, Show) - --- instance Eq (Branch0 m) where --- a == b = view terms a == view terms b --- && view types a == view types b --- && view children a == view children b --- && (fmap fst . view edits) a == (fmap fst . view edits) b - --- -- data ForkFailure = SrcNotFound | DestExists - --- -- -- consider delegating to Names.numHashChars when ready to implement? --- -- -- are those enough? --- -- -- could move this to a read-only field in Branch0 --- -- -- could move a Names0 to a read-only field in Branch0 until it gets too big --- -- numHashChars :: Branch m -> Int --- -- numHashChars _b = 3 - --- -- This type is a little ugly, so we wrap it up with a nice type alias for --- -- use outside this module. --- type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) - --- -- boundedCache :: MonadIO m => Word -> m (Cache m2) --- -- boundedCache = Cache.semispaceCache - --- -- Can use `Cache.nullCache` to disable caching if needed --- cachedRead :: forall m . MonadIO m --- => Cache m --- -> Causal.Deserialize m Raw Raw --- -> (EditHash -> m Patch) --- -> Hash --- -> m (Branch m) --- cachedRead cache deserializeRaw deserializeEdits h = --- Branch <$> Causal.cachedRead cache d h --- where --- fromRaw :: Raw -> m (Branch0 m) --- fromRaw Raw {..} = do --- children <- traverse go _childrenR --- edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash --- pure $ branch0 _termsR _typesR children edits --- go = cachedRead cache deserializeRaw deserializeEdits --- d :: Causal.Deserialize m Raw (Branch0 m) --- d h = deserializeRaw h >>= \case --- RawOne raw -> RawOne <$> fromRaw raw --- RawCons raw h -> flip RawCons h <$> fromRaw raw --- RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw - --- sync --- :: Monad m --- => (Hash -> m Bool) --- -> Causal.Serialize m Raw Raw --- -> (EditHash -> m Patch -> m ()) --- -> Branch m --- -> m () --- sync exists serializeRaw serializeEdits b = do --- _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty --- -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." --- pure () - --- -- serialize a `Branch m` indexed by the hash of its corresponding Raw --- sync' --- :: forall m --- . Monad m --- => (Hash -> m Bool) --- -> Causal.Serialize m Raw Raw --- -> (EditHash -> m Patch -> m ()) --- -> Branch m --- -> StateT (Set Hash) m () --- sync' exists serializeRaw serializeEdits b = Causal.sync exists --- serialize0 --- (view history b) --- where --- serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) --- serialize0 h b0 = case b0 of --- RawOne b0 -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawOne (toRaw b0) --- RawCons b0 ht -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawCons (toRaw b0) ht --- RawMerge b0 hs -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawMerge (toRaw b0) hs --- where --- writeB0 :: Branch0 m -> StateT (Set Hash) m () --- writeB0 b0 = do --- for_ (view children b0) $ \c -> do --- queued <- State.get --- when (Set.notMember (headHash c) queued) $ --- sync' exists serializeRaw serializeEdits c --- for_ (view edits b0) (lift . uncurry serializeEdits) - --- -- this has to serialize the branch0 and its descendants in the tree, --- -- and then serialize the rest of the history of the branch as well - --- toRaw :: Branch0 m -> Raw --- toRaw Branch0 {..} = --- Raw _terms _types (headHash <$> _children) (fst <$> _edits) - --- toCausalRaw :: Branch m -> Causal.Raw Raw Raw --- toCausalRaw = \case --- Branch (Causal.One _h e) -> RawOne (toRaw e) --- Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht --- Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) - --- -- -- copy a path to another path --- -- fork --- -- :: Applicative m --- -- => Path --- -- -> Path --- -- -> Branch m --- -- -> Either ForkFailure (Branch m) --- -- fork src dest root = case getAt src root of --- -- Nothing -> Left SrcNotFound --- -- Just src' -> case setIfNotExists dest src' root of --- -- Nothing -> Left DestExists --- -- Just root' -> Right root' - --- -- -- Move the node at src to dest. --- -- -- It's okay if `dest` is inside `src`, just create empty levels. --- -- -- Try not to `step` more than once at each node. --- -- move :: Applicative m --- -- => Path --- -- -> Path --- -- -> Branch m --- -- -> Either ForkFailure (Branch m) --- -- move src dest root = case getAt src root of --- -- Nothing -> Left SrcNotFound --- -- Just src' -> --- -- -- make sure dest doesn't already exist --- -- case getAt dest root of --- -- Just _destExists -> Left DestExists --- -- Nothing -> --- -- -- find and update common ancestor of `src` and `dest`: --- -- Right $ modifyAt ancestor go root --- -- where --- -- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest --- -- go = deleteAt relSrc . setAt relDest src' - --- -- setIfNotExists --- -- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) --- -- setIfNotExists dest b root = case getAt dest root of --- -- Just _destExists -> Nothing --- -- Nothing -> Just $ setAt dest b root - --- -- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m --- -- setAt path b = modifyAt path (const b) - --- -- deleteAt :: Applicative m => Path -> Branch m -> Branch m --- -- deleteAt path = setAt path empty - --- -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` --- getAt :: Path --- -> Branch m --- -> Maybe (Branch m) --- getAt path root = case Path.uncons path of --- Nothing -> if isEmpty root then Nothing else Just root --- Just (seg, path) -> case Map.lookup seg (_children $ head root) of --- Just b -> getAt path b --- Nothing -> Nothing - --- getAt' :: Path -> Branch m -> Branch m --- getAt' p b = fromMaybe empty $ getAt p b - --- -- getAt0 :: Path -> Branch0 m -> Branch0 m --- -- getAt0 p b = case Path.uncons p of --- -- Nothing -> b --- -- Just (seg, path) -> case Map.lookup seg (_children b) of --- -- Just c -> getAt0 path (head c) --- -- Nothing -> empty0 - --- empty :: Branch m --- empty = Branch $ Causal.one empty0 - --- -- one :: Branch0 m -> Branch m --- -- one = Branch . Causal.one - --- empty0 :: Branch0 m --- empty0 = --- Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty - --- isEmpty0 :: Branch0 m -> Bool --- isEmpty0 = (== empty0) - --- isEmpty :: Branch m -> Bool --- isEmpty = (== empty) - --- step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m --- step f = \case --- Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) --- b -> over history (Causal.stepDistinct f) b - --- -- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- -- stepM f = \case --- -- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 --- -- b -> mapMOf history (Causal.stepDistinctM f) b - --- cons :: Applicative m => Branch0 m -> Branch m -> Branch m --- cons = step . const - --- -- isOne :: Branch m -> Bool --- -- isOne (Branch Causal.One{}) = True --- -- isOne _ = False - --- -- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) --- -- uncons (Branch b) = go <$> Causal.uncons b where --- -- go = over (_Just . _2) Branch - --- -- -- Modify the branch0 at the head of at `path` with `f`, --- -- -- after creating it if necessary. Preserves history. --- -- stepAt :: forall m. Applicative m --- -- => Path --- -- -> (Branch0 m -> Branch0 m) --- -- -> Branch m -> Branch m --- -- stepAt p f = modifyAt p g where --- -- g :: Branch m -> Branch m --- -- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b - --- -- stepManyAt :: (Monad m, Foldable f) --- -- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m --- -- stepManyAt actions = step (stepManyAt0 actions) - --- -- -- Modify the branch0 at the head of at `path` with `f`, --- -- -- after creating it if necessary. Preserves history. --- -- stepAtM :: forall n m. (Functor n, Applicative m) --- -- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- -- stepAtM p f = modifyAtM p g where --- -- g :: Branch m -> n (Branch m) --- -- g (Branch b) = do --- -- b0' <- f (Causal.head b) --- -- pure $ Branch . Causal.consDistinct b0' $ b - --- -- stepManyAtM :: (Monad m, Monad n, Foldable f) --- -- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- -- stepManyAtM actions = stepM (stepManyAt0M actions) - --- -- -- starting at the leaves, apply `f` to every level of the branch. --- -- stepEverywhere --- -- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) --- -- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) --- -- where children = fmap (step $ stepEverywhere f) _children - --- -- -- Creates a function to fix up the children field._1 --- -- -- If the action emptied a child, then remove the mapping, --- -- -- otherwise update it. --- -- -- Todo: Fix this in hashing & serialization instead of here? --- -- getChildBranch :: NameSegment -> Branch0 m -> Branch m --- -- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) - --- -- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m --- -- setChildBranch seg b = over children (updateChildren seg b) - --- -- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch --- -- getPatch seg b = case Map.lookup seg (_edits b) of --- -- Nothing -> pure Patch.empty --- -- Just (_, p) -> p - --- -- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) --- -- getMaybePatch seg b = case Map.lookup seg (_edits b) of --- -- Nothing -> pure Nothing --- -- Just (_, p) -> Just <$> p - --- -- modifyPatches --- -- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) --- -- modifyPatches seg f = mapMOf edits update --- -- where --- -- update m = do --- -- p' <- case Map.lookup seg m of --- -- Nothing -> pure $ f Patch.empty --- -- Just (_, p) -> f <$> p --- -- let h = H.accumulate' p' --- -- pure $ Map.insert seg (h, pure p') m - --- -- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m --- -- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) - --- -- deletePatch :: NameSegment -> Branch0 m -> Branch0 m --- -- deletePatch n = over edits (Map.delete n) - --- -- updateChildren ::NameSegment --- -- -> Branch m --- -- -> Map NameSegment (Branch m) --- -- -> Map NameSegment (Branch m) --- -- updateChildren seg updatedChild = --- -- if isEmpty updatedChild --- -- then Map.delete seg --- -- else Map.insert seg updatedChild - --- -- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- -- Because it's a `Branch`, it overwrites the history at `path`. --- -- modifyAt :: Applicative m --- -- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m --- -- modifyAt path f = runIdentity . modifyAtM path (pure . f) - --- -- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- -- Because it's a `Branch`, it overwrites the history at `path`. --- -- modifyAtM --- -- :: forall n m --- -- . Functor n --- -- => Applicative m -- because `Causal.cons` uses `pure` --- -- => Path --- -- -> (Branch m -> n (Branch m)) --- -- -> Branch m --- -- -> n (Branch m) --- -- modifyAtM path f b = case Path.uncons path of --- -- Nothing -> f b --- -- Just (seg, path) -> do -- Functor --- -- let child = getChildBranch seg (head b) --- -- child' <- modifyAtM path f child --- -- -- step the branch by updating its children according to fixup --- -- pure $ step (setChildBranch seg child') b - --- -- -- stepManyAt0 consolidates several changes into a single step --- -- stepManyAt0 :: forall f m . (Monad m, Foldable f) --- -- => f (Path, Branch0 m -> Branch0 m) --- -- -> Branch0 m -> Branch0 m --- -- stepManyAt0 actions = --- -- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] - --- -- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) --- -- => f (Path, Branch0 m -> n (Branch0 m)) --- -- -> Branch0 m -> n (Branch0 m) --- -- stepManyAt0M actions b = go (toList actions) b where --- -- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) --- -- go actions b = let --- -- -- combines the functions that apply to this level of the tree --- -- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] - --- -- -- groups the actions based on the child they apply to --- -- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] --- -- childActions = --- -- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] - --- -- -- alters the children of `b` based on the `childActions` map --- -- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) --- -- stepChildren children0 = foldM g children0 $ Map.toList childActions --- -- where --- -- g children (seg, actions) = do --- -- -- Recursively applies the relevant actions to the child branch --- -- -- The `findWithDefault` is important - it allows the stepManyAt --- -- -- to create new children at paths that don't previously exist. --- -- child <- stepM (go actions) (Map.findWithDefault empty seg children0) --- -- pure $ updateChildren seg child children --- -- in do --- -- c2 <- stepChildren (view children b) --- -- currentAction (set children c2 b) - --- instance Hashable (Branch0 m) where --- tokens b = --- [ H.accumulateToken (_terms b) --- , H.accumulateToken (_types b) --- , H.accumulateToken (headHash <$> _children b) --- , H.accumulateToken (fst <$> _edits b) --- ] - --- -- -- getLocalBranch :: Hash -> IO Branch --- -- -- getGithubBranch :: RemotePath -> IO Branch --- -- -- getLocalEdit :: GUID -> IO Patch - --- -- -- todo: consider inlining these into Actions2 --- -- addTermName --- -- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- -- addTermName r new md = --- -- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- -- addTypeName --- -- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- -- addTypeName r new md = --- -- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- -- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m --- -- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m - --- -- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m --- -- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) --- -- = over terms (Star3.deletePrimaryD1 (r,n)) b --- -- deleteTermName _ _ b = b - --- -- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m --- -- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) --- -- = over types (Star3.deletePrimaryD1 (r,n)) b --- -- deleteTypeName _ _ b = b - --- -- namesDiff :: Branch m -> Branch m -> Names.Diff --- -- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) - --- lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) --- lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b - --- diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff --- diff0 old new = do --- newEdits <- sequenceA $ snd <$> _edits new --- oldEdits <- sequenceA $ snd <$> _edits old --- let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) --- (Map.mapMissing $ \_ p -> Patch.diff mempty p) --- (Map.zipWithMatched (const Patch.diff)) --- newEdits --- oldEdits --- pure $ BranchDiff --- { addedTerms = Star3.difference (_terms new) (_terms old) --- , removedTerms = Star3.difference (_terms old) (_terms new) --- , addedTypes = Star3.difference (_types new) (_types old) --- , removedTypes = Star3.difference (_types old) (_types new) --- , changedPatches = diffEdits --- } - --- transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n --- transform f b = case _history b of --- causal -> Branch . Causal.transform f $ transformB0s f causal --- where --- transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n --- transformB0 f b = --- b { _children = transform f <$> _children b --- , _edits = second f <$> _edits b --- } - --- transformB0s :: Functor m => (forall a . m a -> n a) --- -> Causal m Raw (Branch0 m) --- -> Causal m Raw (Branch0 n) --- transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) - --- -- data BranchAttentions = BranchAttentions --- -- { -- Patches that were edited on the right but entirely removed on the left. --- -- removedPatchEdited :: [Name] --- -- -- Patches that were edited on the left but entirely removed on the right. --- -- , editedPatchRemoved :: [Name] --- -- } - --- -- instance Semigroup BranchAttentions where --- -- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 --- -- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - --- -- instance Monoid BranchAttentions where --- -- mempty = BranchAttentions [] [] --- -- mappend = (<>) - --- -- data RefCollisions = --- -- RefCollisions { termCollisions :: Relation Name Name --- -- , typeCollisions :: Relation Name Name --- -- } deriving (Eq, Show) - --- -- instance Semigroup RefCollisions where --- -- (<>) = mappend --- -- instance Monoid RefCollisions where --- -- mempty = RefCollisions mempty mempty --- -- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) --- -- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs index b3c8e88e01..c45e1b66ee 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs @@ -17,67 +17,26 @@ import Unison.Prelude hiding (empty) import Prelude hiding (head,read,subtract) -import Control.Lens hiding ( children, cons, transform, uncons ) -import qualified Control.Monad.State as State -import Control.Monad.State ( StateT ) -import Data.Bifunctor ( second ) -import qualified Data.Map as Map -import qualified Data.Map.Merge.Lazy as Map -import qualified Data.Set as Set -import qualified Unison.Codebase.Patch as Patch -import Unison.Codebase.Patch ( Patch ) -import qualified Unison.Codebase.Causal as Causal +import qualified Data.Set as Set +import Unison.Codebase.Branch import qualified Unison.Codebase.Causal.FoldHistory as Causal -import Unison.Codebase.Causal ( Causal - , pattern RawOne - , pattern RawCons - , pattern RawMerge - ) -import Unison.Codebase.Path ( Path(..) ) -import qualified Unison.Codebase.Path as Path -import Unison.NameSegment ( NameSegment ) -import qualified Unison.NameSegment as NameSegment -import qualified Unison.Codebase.Metadata as Metadata -import qualified Unison.Hash as Hash -import Unison.Hashable ( Hashable ) -import qualified Unison.Hashable as H -import Unison.Name ( Name(..) ) -import qualified Unison.Name as Name -import qualified Unison.Names2 as Names -import qualified Unison.Names3 as Names -import Unison.Names2 ( Names'(Names), Names0 ) -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) -import qualified Unison.Referent as Referent -import qualified Unison.Reference as Reference - -import qualified U.Util.Cache as Cache -import qualified Unison.Util.Relation as R -import Unison.Util.Relation ( Relation ) -import qualified Unison.Util.Relation4 as R4 -import qualified Unison.Util.List as List -import Unison.Util.Map ( unionWithM ) -import qualified Unison.Util.Star3 as Star3 -import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import qualified Unison.HashQualified as HQ import Unison.HashQualified (HashQualified) -import qualified Unison.LabeledDependency as LD +import qualified Unison.HashQualified as HQ import Unison.LabeledDependency (LabeledDependency) -import Unison.Codebase.Branch +import qualified Unison.LabeledDependency as LD +import Unison.Name (Name (..)) +import Unison.Names2 (Names' (Names), Names0) +import qualified Unison.Names2 as Names +import qualified Unison.Names3 as Names +import Unison.Reference (Reference) +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent +import qualified Unison.Util.Relation as R toNames0 :: Branch0 m -> Names0 toNames0 b = Names (R.swap . deepTerms $ b) (R.swap . deepTypes $ b) --- This stops searching for a given ShortHash once it encounters --- any term or type in any Branch0 that satisfies that ShortHash. -findHistoricalSHs - :: Monad m => Set ShortHash -> Branch m -> m (Set ShortHash, Names0) -findHistoricalSHs = findInHistory - (\sh r _n -> sh `SH.isPrefixOf` Referent.toShortHash r) - (\sh r _n -> sh `SH.isPrefixOf` Reference.toShortHash r) - -- This stops searching for a given HashQualified once it encounters -- any term or type in any Branch0 that satisfies that HashQualified. findHistoricalHQs :: Monad m diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs index 13819c59ad..e6026d268f 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs @@ -2,33 +2,15 @@ module Unison.Codebase.CodeLookup where import Unison.Prelude -import Control.Monad.Morph -import qualified Data.Map as Map --- import Unison.UnisonFile ( UnisonFile ) --- import qualified Unison.UnisonFile as UF -import qualified Unison.Term as Term -import Unison.Term ( Term ) -import Unison.Var ( Var ) -import qualified Unison.Reference as Reference -import Unison.DataDeclaration (Decl) +import Control.Monad.Morph (MFunctor (..)) import qualified Data.Set as Set -import qualified Unison.Util.Set as Set +import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as DD - --- fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a --- fromUnisonFile uf = CodeLookup tm ty where --- tm id = pure $ Map.lookup id termMap --- ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 --- typeMap1 = Map.fromList [ (id, Right dd) | --- (_, (Reference.DerivedId id, dd)) <- --- Map.toList (UF.dataDeclarations uf) ] --- typeMap2 = Map.fromList [ (id, Left ad) | --- (_, (Reference.DerivedId id, ad)) <- --- Map.toList (UF.effectDeclarations uf) ] --- tmm = Map.fromList (UF.terms uf) --- termMap = Map.fromList [ (id, e) | --- (_, (id, e)) <- --- Map.toList (Term.hashComponents tmm) ] +import qualified Unison.Reference as Reference +import Unison.Term (Term) +import qualified Unison.Term as Term +import qualified Unison.Util.Set as Set +import Unison.Var (Var) data CodeLookup v m a = CodeLookup { diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs index be7e3f9cdd..ce7ce0150d 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs @@ -2,17 +2,13 @@ module Unison.Codebase.CodeLookup.Util where import Unison.Prelude -import Control.Monad.Morph import qualified Data.Map as Map import Unison.Codebase.CodeLookup -import Unison.DataDeclaration (Decl) import qualified Unison.Reference as Reference -import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.UnisonFile as UF import Unison.UnisonFile.Type (UnisonFile) import Unison.Var (Var) -import qualified Unison.UnisonFile.Type as UF fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a fromUnisonFile uf = CodeLookup tm ty where diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index 22ac33ddef..dc3889a687 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -32,7 +32,6 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Branch ( Branch ) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch -import Unison.Codebase.GitError import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.SyncMode ( SyncMode ) import Unison.Names3 ( Names, Names0 ) diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 82215a2539..578d240bd3 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -9,7 +9,6 @@ module Unison.Codebase.MainTerm where import Unison.Prelude import Unison.Parser.Ann (Ann) -import qualified Unison.Parser as Parser import qualified Unison.Term as Term import Unison.Term ( Term ) import Unison.Var ( Var ) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index bf02d25d1e..8d3d019a00 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -65,23 +65,19 @@ module Unison.Codebase.Path where import Unison.Prelude hiding (empty, toList) -import Data.Bifunctor ( first ) -import Data.List.Extra ( stripPrefix, dropPrefix ) -import Control.Lens hiding (Empty, unsnoc, cons, snoc) +import Control.Lens hiding (Empty, cons, snoc, unsnoc) import qualified Control.Lens as Lens import qualified Data.Foldable as Foldable -import qualified Data.Text as Text -import Data.Sequence (Seq((:<|),(:|>) )) -import qualified Data.Sequence as Seq -import Unison.Name ( Name, Convert, Parse ) -import qualified Unison.Name as Name -import Unison.Util.Monoid (intercalateMap) -import qualified Unison.Lexer as Lexer +import Data.List.Extra (dropPrefix) +import Data.Sequence (Seq ((:<|), (:|>))) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text import qualified Unison.HashQualified' as HQ' -import qualified Unison.ShortHash as SH - -import Unison.NameSegment ( NameSegment(NameSegment)) -import qualified Unison.NameSegment as NameSegment +import Unison.Name (Convert, Name, Parse) +import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment (NameSegment)) +import qualified Unison.NameSegment as NameSegment +import Unison.Util.Monoid (intercalateMap) -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] newtype Path = Path { toSeq :: Seq NameSegment } deriving (Eq, Ord, Semigroup, Monoid) @@ -137,7 +133,6 @@ type HQSplit = (Path, HQ'.HQSegment) type Split' = (Path', NameSegment) type HQSplit' = (Path', HQ'.HQSegment) -type SplitAbsolute = (Absolute, NameSegment) type HQSplitAbsolute = (Absolute, HQ'.HQSegment) -- | examples: @@ -155,152 +150,10 @@ prefix (Absolute (Path prefix)) (Path' p) = case p of Left (unabsolute -> abs) -> abs Right (unrelative -> rel) -> Path $ prefix <> toSeq rel --- .libs.blah.poo is Absolute --- libs.blah.poo is Relative --- Left is some parse error tbd -parsePath' :: String -> Either String Path' -parsePath' p = case parsePathImpl' p of - Left e -> Left e - Right (p, "" ) -> Right p - Right (p, rem) -> case parseSegment rem of - Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg)) - Right (_, rem) -> - Left ("extra characters after " <> show p <> ": " <> show rem) - Left e -> Left e - --- implementation detail of parsePath' and parseSplit' --- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") --- foo.bar.baz becomes `Right (foo.bar, "baz") --- baz becomes `Right (, "baz") --- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths. --- TODO: Get rid of this thing. -parsePathImpl' :: String -> Either String (Path', String) -parsePathImpl' p = case p of - "." -> Right (Path' . Left $ absoluteEmpty, "") - '.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p - p -> over _1 (Path' . Right . Relative . fromList) <$> segs p - where - go f p = case f p of - Right (a, "") -> case Lens.unsnoc (Name.segments' $ Text.pack a) of - Nothing -> Left "empty path" - Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last) - Right (segs, '.' : rem) -> - let segs' = Name.segments' (Text.pack segs) - in Right (NameSegment <$> segs', rem) - Right (segs, rem) -> - Left $ "extra characters after " <> segs <> ": " <> show rem - Left e -> Left e - segs p = go parseSegment p - -parseSegment :: String -> Either String (String, String) -parseSegment s = - first show - . (Lexer.wordyId <> Lexer.symbolyId) - <> unit' - <> const (Left ("I expected an identifier but found " <> s)) - $ s - -wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment -wordyNameSegment s = case Lexer.wordyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem - -optionalWordyNameSegment :: String -> Either String NameSegment -optionalWordyNameSegment "" = Right $ NameSegment "" -optionalWordyNameSegment s = wordyNameSegment s - --- Parse a name segment like "()" -unit' :: String -> Either String (String, String) -unit' s = case stripPrefix "()" s of - Nothing -> Left $ "Expected () but found: " <> s - Just rem -> Right ("()", rem) - -unit :: String -> Either String NameSegment -unit s = case unit' s of - Right (_, "" ) -> Right $ NameSegment "()" - Right (_, rem) -> Left $ "trailing characters after (): " <> show rem - Left _ -> Left $ "I don't know how to parse " <> s - - -definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s - where - symbolyNameSegment s = case Lexer.symbolyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem - --- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz) --- parseSplit' wordyNameSegment "foo.bar.+" returns Left err --- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +) -parseSplit' :: (String -> Either String NameSegment) - -> String - -> Either String Split' -parseSplit' lastSegment p = do - (p', rem) <- parsePathImpl' p - seg <- lastSegment rem - pure (p', seg) - -parseShortHashOrHQSplit' :: String -> Either String (Either SH.ShortHash HQSplit') -parseShortHashOrHQSplit' s = - case Text.breakOn "#" $ Text.pack s of - ("","") -> error $ "encountered empty string parsing '" <> s <> "'" - (n,"") -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - pure $ Right (p, HQ'.NameOnly seg) - ("", sh) -> do - sh <- maybeToRight (shError s) . SH.fromText $ sh - pure $ Left sh - (n, sh) -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - hq <- maybeToRight (shError s) . - fmap (\sh -> (p, HQ'.HashQualified seg sh)) . - SH.fromText $ sh - pure $ Right hq - where - shError s = "couldn't parse shorthash from " <> s - -parseHQSplit :: String -> Either String HQSplit -parseHQSplit s = case parseHQSplit' s of - Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg) - Right (Path' Left{}, _) -> - Left $ "Sorry, you can't use an absolute name like " <> s <> " here." - Left e -> Left e - -parseHQSplit' :: String -> Either String HQSplit' -parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of - ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" - ("", _ ) -> Left "Sorry, you can't use a hash-only reference here." - (n , "") -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - pure (p, HQ'.NameOnly seg) - (n, sh) -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - maybeToRight (shError s) - . fmap (\sh -> (p, HQ'.HashQualified seg sh)) - . SH.fromText - $ sh - where - shError s = "couldn't parse shorthash from " <> s - parsePath n = do - x <- parsePathImpl' $ Text.unpack n - pure $ case x of - (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") - x -> x toAbsoluteSplit :: Absolute -> (Path', a) -> (Absolute, a) toAbsoluteSplit a (p, s) = (resolve a p, s) -fromSplit' :: (Path', a) -> (Path, a) -fromSplit' (Path' (Left (Absolute p)), a) = (p, a) -fromSplit' (Path' (Right (Relative p)), a) = (p, a) - fromAbsoluteSplit :: (Absolute, a) -> (Path, a) fromAbsoluteSplit (Absolute p, a) = (p, a) @@ -310,9 +163,6 @@ absoluteEmpty = Absolute empty relativeEmpty' :: Path' relativeEmpty' = Path' (Right (Relative empty)) -relativeSingleton :: NameSegment -> Relative -relativeSingleton = Relative . Path . Seq.singleton - toPath' :: Path -> Path' toPath' = \case Path (NameSegment "" :<| tail) -> Path' . Left . Absolute . Path $ tail @@ -364,12 +214,6 @@ unsnoc = Lens.unsnoc uncons :: Path -> Maybe (NameSegment, Path) uncons = Lens.uncons ---asDirectory :: Path -> Text ---asDirectory p = case toList p of --- NameSegment "_root_" : (Seq.fromList -> tail) -> --- "/" <> asDirectory (Path tail) --- other -> Text.intercalate "/" . fmap NameSegment.toText $ other - -- > Path.fromName . Name.unsafeFromText $ ".Foo.bar" -- /Foo/bar -- Int./ -> "Int"/"/" @@ -397,17 +241,6 @@ toName = Name.unsafeFromText . toText toName' :: Path' -> Name toName' = Name.unsafeFromText . toText' --- Returns the nearest common ancestor, along with the --- two inputs relativized to that ancestor. -relativeToAncestor :: Path -> Path -> (Path, Path, Path) -relativeToAncestor (Path a) (Path b) = case (a, b) of - (ha :<| ta, hb :<| tb) | ha == hb -> - let (ancestor, relA, relB) = relativeToAncestor (Path ta) (Path tb) - in (ha `cons` ancestor, relA, relB) - -- nothing in common - _ -> (empty, Path a, Path b) - -pattern Parent h t = Path (NameSegment h :<| t) pattern Empty = Path Seq.Empty empty :: Path diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index a88a9207f7..cc574f38b8 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -20,24 +20,17 @@ import Unison.Prelude hiding (empty, toList) import Unison.Codebase.Path -import Data.Bifunctor ( first ) -import Data.List.Extra ( stripPrefix, dropPrefix ) -import Control.Lens hiding (unsnoc, cons, snoc) +import Control.Lens (_1, over) import qualified Control.Lens as Lens -import qualified Data.Foldable as Foldable -import qualified Data.Text as Text -import Data.Sequence (Seq((:<|),(:|>) )) -import qualified Data.Sequence as Seq -import Unison.Name ( Name, Convert, Parse ) -import qualified Unison.Name as Name -import Unison.Util.Monoid (intercalateMap) -import qualified Unison.Lexer as Lexer +import Data.Bifunctor (first) +import Data.List.Extra (stripPrefix) +import qualified Data.Text as Text import qualified Unison.HashQualified' as HQ' +import qualified Unison.Lexer as Lexer +import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment (NameSegment)) import qualified Unison.ShortHash as SH -import Unison.NameSegment ( NameSegment(NameSegment)) -import qualified Unison.NameSegment as NameSegment - -- .libs.blah.poo is Absolute -- libs.blah.poo is Relative -- Left is some parse error tbd @@ -90,10 +83,6 @@ wordyNameSegment s = case Lexer.wordyId0 s of Right (a, rem) -> Left $ "trailing characters after " <> show a <> ": " <> show rem -optionalWordyNameSegment :: String -> Either String NameSegment -optionalWordyNameSegment "" = Right $ NameSegment "" -optionalWordyNameSegment s = wordyNameSegment s - -- Parse a name segment like "()" unit' :: String -> Either String (String, String) unit' s = case stripPrefix "()" s of @@ -176,83 +165,3 @@ parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of pure $ case x of (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") x -> x - -toAbsoluteSplit :: Absolute -> (Path', a) -> (Absolute, a) -toAbsoluteSplit a (p, s) = (resolve a p, s) - -fromSplit' :: (Path', a) -> (Path, a) -fromSplit' (Path' (Left (Absolute p)), a) = (p, a) -fromSplit' (Path' (Right (Relative p)), a) = (p, a) - -fromAbsoluteSplit :: (Absolute, a) -> (Path, a) -fromAbsoluteSplit (Absolute p, a) = (p, a) - --- splitFromName :: Name -> Maybe Split --- splitFromName = unsnoc . fromName - -unprefixName :: Absolute -> Name -> Name -unprefixName prefix = toName . unprefix prefix . fromName' - -prefixName :: Absolute -> Name -> Name -prefixName p = toName . prefix p . fromName' - -singleton :: NameSegment -> Path -singleton n = fromList [n] - -cons :: NameSegment -> Path -> Path -cons = Lens.cons - -snoc :: Path -> NameSegment -> Path -snoc = Lens.snoc - -snoc' :: Path' -> NameSegment -> Path' -snoc' = Lens.snoc - -unsnoc :: Path -> Maybe (Path, NameSegment) -unsnoc = Lens.unsnoc - -uncons :: Path -> Maybe (NameSegment, Path) -uncons = Lens.uncons - ---asDirectory :: Path -> Text ---asDirectory p = case toList p of --- NameSegment "_root_" : (Seq.fromList -> tail) -> --- "/" <> asDirectory (Path tail) --- other -> Text.intercalate "/" . fmap NameSegment.toText $ other - --- -- > Path.fromName . Name.unsafeFromText $ ".Foo.bar" --- -- /Foo/bar --- -- Int./ -> "Int"/"/" --- -- pkg/Int.. -> "pkg"/"Int"/"." --- -- Int./foo -> error because "/foo" is not a valid NameSegment --- -- and "Int." is not a valid NameSegment --- -- and "Int" / "" / "foo" is not a valid path (internal "") --- -- todo: fromName needs to be a little more complicated if we want to allow --- -- identifiers called Function.(.) --- fromName :: Name -> Path --- fromName = fromList . Name.segments - --- fromName' :: Name -> Path' --- fromName' n = case take 1 (Name.toString n) of --- "." -> Path' . Left . Absolute $ Path seq --- _ -> Path' . Right $ Relative path --- where --- path = fromName n --- seq = toSeq path - --- toName :: Path -> Name --- toName = Name.unsafeFromText . toText - --- | Convert a Path' to a Name -toName' :: Path' -> Name -toName' = Name.unsafeFromText . toText' - -fromText :: Text -> Path -fromText = \case - "" -> empty - t -> fromList $ NameSegment <$> Name.segments' t - -toText' :: Path' -> Text -toText' = \case - Path' (Left (Absolute path)) -> Text.cons '.' (toText path) - Path' (Right (Relative path)) -> toText path diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 73f2885978..6dcafafaef 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -5,25 +5,24 @@ module Unison.Codebase.Runtime where import Unison.Prelude -import qualified Unison.ABT as ABT import Data.Bifunctor (first) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Unison.Codebase.CodeLookup as CL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import Unison.Builtin.Decls (tupleTerm, pattern TupleTerm') +import qualified Unison.Codebase.CodeLookup as CL import qualified Unison.Codebase.CodeLookup.Util as CL -import Unison.UnisonFile ( UnisonFile ) import Unison.Parser.Ann (Ann) -import qualified Unison.Term as Term -import Unison.Type ( Type ) -import Unison.Var ( Var ) -import qualified Unison.Var as Var -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.UnisonFile as UF -import qualified Unison.UnisonFile.Type as UF -import Unison.Builtin.Decls (pattern TupleTerm', tupleTerm) -import qualified Unison.Util.Pretty as P import qualified Unison.PrettyPrintEnv as PPE +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Term as Term +import Unison.Type (Type) +import Unison.UnisonFile (UnisonFile) +import qualified Unison.UnisonFile as UF +import qualified Unison.Util.Pretty as P +import Unison.Var (Var) +import qualified Unison.Var as Var import Unison.WatchKind (WatchKind) import qualified Unison.WatchKind as WK diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 531f19d9b0..e1676aab9e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -49,7 +49,6 @@ import qualified Unison.Hash as V1 import qualified Unison.Kind as V1.Kind import qualified Unison.NameSegment as V1 import Unison.Parser.Ann (Ann) -import qualified Unison.Parser as Ann import qualified Unison.Parser.Ann as Ann import qualified Unison.Pattern as V1.Pattern import qualified Unison.Reference as V1 @@ -61,7 +60,6 @@ import qualified Unison.Term as V1.Term import qualified Unison.Type as V1.Type import qualified Unison.Util.Relation as Relation import qualified Unison.Util.Star3 as V1.Star3 -import qualified Unison.Var as V1.Var import qualified Unison.Var as Var import qualified Unison.WatchKind as V1.WK diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index 55db0cca00..b2acb739be 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -23,7 +23,6 @@ import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.TypeParser as TypeParser import Unison.UnisonFile (UnisonFile(..)) -import qualified Unison.UnisonFile as UF import qualified Unison.UnisonFile.Env as UF import Unison.UnisonFile.Names (environmentFor) import qualified Unison.Util.List as List @@ -244,7 +243,7 @@ declaration = do dataDeclaration :: forall v . Var v - => Maybe (L.Token DD.Modifier) + => Maybe (L.Token DD.Modifier) -> P v (v, DataDeclaration v Ann, Accessors v) dataDeclaration mod = do keywordTok <- fmap void (reserved "type") <|> openBlockWith "type" @@ -283,9 +282,9 @@ dataDeclaration mod = do -- otherwise ann of name closingAnn :: Ann closingAnn = last (ann eq : ((\(_,_,t) -> ann t) <$> constructors)) - case mod of - Nothing -> P.customFailure $ MissingTypeModifier ("type" <$ keywordTok) name - Just mod' -> + case mod of + Nothing -> P.customFailure $ MissingTypeModifier ("type" <$ keywordTok) name + Just mod' -> pure (L.payload name, DD.mkDataDecl' (L.payload mod') (ann mod' <> closingAnn) typeArgVs constructors, accessors) diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index 3f41742b94..394c92db8b 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -34,7 +34,6 @@ import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.Typechecker.Context as Context import qualified Unison.UnisonFile as UF import qualified Unison.UnisonFile.Names as UF -import qualified Unison.UnisonFile.Type as UF import qualified Unison.Util.List as List import qualified Unison.Util.Relation as Rel import Unison.Var (Var) diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 988b0259a7..374124b573 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -47,7 +47,6 @@ import qualified Unison.UnisonFile.Error as UF import Unison.Util.Bytes (Bytes) import Unison.Name as Name import Unison.Names3 (Names) -import qualified Unison.Names3 as Names import qualified Unison.Names.ResolutionResult as Names import Control.Monad.Reader.Class (asks) import qualified Unison.Hashable as Hashable diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index 4ef167f346..2cbb87c293 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -8,11 +8,9 @@ import Unison.HashQualified ( HashQualified ) import Unison.Name ( Name ) import Unison.Reference ( Reference ) import Unison.Referent ( Referent ) -import qualified Data.Map as Map import qualified Unison.HashQualified as HQ import qualified Unison.Referent as Referent import qualified Unison.ConstructorType as CT -import qualified Data.Set as Set data PrettyPrintEnv = PrettyPrintEnv { -- names for terms, constructors, and requests @@ -33,18 +31,6 @@ unionLeft e1 e2 = PrettyPrintEnv (\r -> terms e1 r <|> terms e2 r) (\r -> types e1 r <|> types e2 r) -assignTermName - :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv -assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) - -fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv -fromTypeNames types = - let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) - -fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv -fromTermNames tms = - let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) - -- todo: these need to be a dynamic length, but we need additional info todoHashLength :: Int todoHashLength = 10 diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs index 91c05d41be..43416c3637 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs @@ -4,35 +4,13 @@ module Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) where import Unison.Prelude -import Unison.HashQualified ( HashQualified ) -import Unison.Name ( Name ) -import Unison.Names3 ( Names ) -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) -import Unison.Util.List (safeHead) -import qualified Data.Map as Map -import qualified Unison.HashQualified as HQ -import qualified Unison.Name as Name -import qualified Unison.Names3 as Names -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import qualified Unison.ConstructorType as CT import qualified Data.Set as Set +import qualified Unison.HashQualified as HQ +import qualified Unison.Name as Name +import Unison.Names3 (Names) +import qualified Unison.Names3 as Names import Unison.PrettyPrintEnv (PrettyPrintEnv (PrettyPrintEnv)) -import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl)) - --- data PrettyPrintEnv = PrettyPrintEnv { --- -- names for terms, constructors, and requests --- terms :: Referent -> Maybe (HashQualified Name), --- -- names for types --- types :: Reference -> Maybe (HashQualified Name) } - --- 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) - --- instance Show PrettyPrintEnv where --- show _ = "PrettyPrintEnv" +import Unison.Util.List (safeHead) fromNames :: Int -> Names -> PrettyPrintEnv fromNames len names = PrettyPrintEnv terms' types' where @@ -44,101 +22,3 @@ fromSuffixNames :: Int -> Names -> PrettyPrintEnv fromSuffixNames len names = PrettyPrintEnv terms' types' where terms' r = safeHead $ Names.suffixedTermName len r names types' r = safeHead $ Names.suffixedTypeName len r names - -fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl -fromNamesDecl len names = - PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) - --- -- A pair of PrettyPrintEnvs: --- -- - suffixifiedPPE uses the shortest unique suffix --- -- - unsuffixifiedPPE uses the shortest full name --- -- --- -- Generally, we want declarations LHS (the `x` in `x = 23`) to use the --- -- unsuffixified names, so the LHS is an accurate description of where in the --- -- namespace the definition lives. For everywhere else, we can use the --- -- suffixified version. --- data PrettyPrintEnvDecl = PrettyPrintEnvDecl { --- unsuffixifiedPPE :: PrettyPrintEnv, --- suffixifiedPPE :: PrettyPrintEnv --- } deriving Show - --- -- declarationPPE uses the full name for references that are --- -- part the same cycle as the input reference, used to ensures --- -- recursive definitions are printed properly, for instance: --- -- --- -- foo.bar x = foo.bar x --- -- and not --- -- foo.bar x = bar x --- declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv --- declarationPPE ppe rd = PrettyPrintEnv tm ty where --- comp = Reference.members (Reference.componentFor rd) --- tm r0@(Referent.Ref r) = if Set.member r comp --- then terms (unsuffixifiedPPE ppe) r0 --- else terms (suffixifiedPPE ppe) r0 --- tm r = terms (suffixifiedPPE ppe) r --- ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r --- else types (suffixifiedPPE ppe) r - --- -- Left-biased union of environments --- unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv --- unionLeft e1 e2 = PrettyPrintEnv --- (\r -> terms e1 r <|> terms e2 r) --- (\r -> types e1 r <|> types e2 r) - --- assignTermName --- :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv --- assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) - --- fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv --- fromTypeNames types = --- let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) - --- fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv --- fromTermNames tms = --- let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) - --- -- todo: these need to be a dynamic length, but we need additional info --- todoHashLength :: Int --- todoHashLength = 10 - --- termName :: PrettyPrintEnv -> Referent -> HashQualified Name --- termName env r = --- fromMaybe (HQ.take todoHashLength $ HQ.fromReferent r) (terms env r) - --- typeName :: PrettyPrintEnv -> Reference -> HashQualified Name --- typeName env r = --- fromMaybe (HQ.take todoHashLength $ HQ.fromReference r) (types env r) - --- patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name --- patternName env r cid = --- case patterns env r cid of --- Just name -> name --- Nothing -> HQ.take todoHashLength $ HQ.fromPattern r cid - --- instance Monoid PrettyPrintEnv where --- mempty = PrettyPrintEnv (const Nothing) (const Nothing) --- mappend = unionLeft --- instance Semigroup PrettyPrintEnv where --- (<>) = mappend - --- -- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' --- -- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. - --- -- Note that a Suffix can include dots. --- type Suffix = Text --- -- Each member of a Prefix list is dot-free. --- type Prefix = [Text] --- -- Keys are FQNs, values are shorter names which are equivalent, thanks to use --- -- statements that are in scope. --- type Imports = Map Name Suffix - --- -- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. --- elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name --- elideFQN imports hq = --- let hash = HQ.toHash hq --- name' = do name <- HQ.toName hq --- let hit = fmap Name.unsafeFromText (Map.lookup name imports) --- -- Cut out the "const id $" to get tracing of FQN elision attempts. --- let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) --- t (pure $ fromMaybe name hit) --- in HQ.fromNameHash name' hash diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs index c39a16721b..ecf2d1af5e 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs @@ -4,22 +4,18 @@ module Unison.PrettyPrintEnv.Util where import Unison.Prelude -import Unison.HashQualified ( HashQualified ) -import Unison.Name ( Name ) -import Unison.Names3 ( Names ) -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) -import Unison.Util.List (safeHead) -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Unison.HashQualified as HQ -import qualified Unison.HashQualified' as HQ' -import qualified Unison.Name as Name -import qualified Unison.Names3 as Names +import Unison.HashQualified (HashQualified) +import qualified Unison.HashQualified as HQ +import Unison.Name (Name) +import qualified Unison.Name as Name import Unison.PrettyPrintEnv -import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl, suffixifiedPPE, unsuffixifiedPPE)) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (suffixifiedPPE, unsuffixifiedPPE)) +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent -- fromNames :: Int -> Names -> PrettyPrintEnv -- fromNames len names = PrettyPrintEnv terms' types' where diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 8562df2e7b..2ba2f413da 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -24,7 +24,6 @@ import qualified Unison.HashQualified as HQ import Unison.Kind (Kind) import qualified Unison.Kind as Kind import qualified Unison.Lexer as L -import qualified Unison.Lexer.Pos as L import Unison.Name ( Name ) import Unison.Parser (Annotated, ann) import qualified Unison.Parser as Parser @@ -39,7 +38,6 @@ import qualified Unison.Type as Type import qualified Unison.Typechecker.Context as C import Unison.Typechecker.TypeError import qualified Unison.Typechecker.TypeVar as TypeVar -import qualified Unison.UnisonFile as UF import qualified Unison.UnisonFile.Error as UF import Unison.Util.AnnotatedText (AnnotatedText) import qualified Unison.Util.AnnotatedText as AT @@ -53,7 +51,6 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.TermPrinter as TermPrinter import qualified Unison.Util.Pretty as Pr import Unison.Util.Pretty (Pretty, ColorText) -import qualified Unison.Names3 as Names import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name import Unison.HashQualified (HashQualified) @@ -74,7 +71,7 @@ defaultWidth :: Pr.Width defaultWidth = 60 -- Various links used in error messages, collected here for a quick overview -structuralVsUniqueDocsLink :: IsString a => Pretty a +structuralVsUniqueDocsLink :: IsString a => Pretty a structuralVsUniqueDocsLink = "https://www.unisonweb.org/docs/language-reference/#unique-types" fromOverHere' @@ -1295,12 +1292,12 @@ prettyParseError s = \case missing = Set.null referents go (Parser.ResolutionFailures failures) = Pr.border 2 . prettyResolutionFailures s $ failures - go (Parser.MissingTypeModifier keyword name) = Pr.lines + go (Parser.MissingTypeModifier keyword name) = Pr.lines [ Pr.wrap $ - "I expected to see `structural` or `unique` at the start of this line:" + "I expected to see `structural` or `unique` at the start of this line:" , "" , tokensAsErrorSite s [void keyword, void name] - , Pr.wrap $ "Learn more about when to use `structural` vs `unique` in the Unison Docs: " + , Pr.wrap $ "Learn more about when to use `structural` vs `unique` in the Unison Docs: " <> structuralVsUniqueDocsLink ] diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index f9f44cc857..226fd53ade 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -90,7 +90,6 @@ import qualified Unison.Util.Star3 as Star3 import qualified Unison.Util.SyntaxText as UST import Unison.Var (Var) import qualified Unison.Server.Doc as Doc -import qualified Unison.UnisonFile as UF import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject import qualified Unison.WatchKind as WK import qualified Unison.PrettyPrintEnv.Util as PPE diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index e35a17eb7f..2b7b3ec818 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -34,56 +34,28 @@ where import Unison.Prelude import Control.Lens -import Data.Bifunctor (second, first) -import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Unison.ABT as ABT +import qualified Unison.Builtin.Decls as DD import qualified Unison.ConstructorType as CT -import Unison.DataDeclaration (DataDeclaration) -import Unison.DataDeclaration (EffectDeclaration(..)) -import Unison.DataDeclaration (hashDecls) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import qualified Unison.DataDeclaration as DD -import qualified Unison.DataDeclaration.Names as DD -import qualified Unison.Builtin.Decls as DD -import qualified Unison.Name as Name --- import qualified Unison.Names3 as Names -import qualified Unison.Names.ResolutionResult as Names -import Unison.Reference (Reference) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import Unison.Term (Term) -import qualified Unison.Term as Term -import Unison.Type (Type) -import qualified Unison.Type as Type -import Unison.UnisonFile.Type (UnisonFile(..), TypecheckedUnisonFile(..), pattern UnisonFile, pattern TypecheckedUnisonFile) -import qualified Unison.Util.List as List -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as Relation -import Unison.Var (Var) -import qualified Unison.Var as Var -import qualified Unison.Typechecker.TypeLookup as TL -import Unison.Names3 (Names0) -import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) --- import qualified Unison.Typechecker.Components as Components +import qualified Unison.LabeledDependency as LD +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.Typechecker.TypeLookup as TL +import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), pattern TypecheckedUnisonFile, pattern UnisonFile) +import qualified Unison.Util.List as List +import Unison.Var (Var) import Unison.WatchKind (WatchKind, pattern TestWatch) -import qualified Unison.Codebase.CodeLookup as CL -import qualified Unison.Util.Set as Set -import Control.Monad.State (State, evalState, get) - --- data UnisonFile v a = UnisonFileId { --- dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a), --- effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a), --- terms :: [(v, Term v a)], --- watches :: Map WatchKind [(v, Term v a)] --- } deriving Show - --- pattern UnisonFile ds es tms ws <- --- UnisonFileId (fmap (first Reference.DerivedId) -> ds) --- (fmap (first Reference.DerivedId) -> es) --- tms --- ws --- {-# COMPLETE UnisonFile #-} dataDeclarations :: UnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId @@ -112,22 +84,6 @@ typecheckingTerm uf = f w = let wa = ABT.annotation w in Term.ann wa w (DD.testResultType wa) testWatches = map (second f) $ watchesOfKind TestWatch uf --- Converts a file and a body to a single let rec with the given body. -uberTerm' :: (Var v, Monoid a) => UnisonFile v a -> Term v a -> Term v a -uberTerm' uf body = - Term.letRec' True (terms uf <> allWatches uf) $ body - --- -- A UnisonFile after typechecking. Terms are split into groups by --- -- cycle and the type of each term is known. --- data TypecheckedUnisonFile v a = --- TypecheckedUnisonFileId { --- dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a), --- effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), --- topLevelComponents' :: [[(v, Term v a, Type v a)]], --- watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], --- hashTermsId :: Map v (Reference.Id, Term v a, Type v a) --- } deriving Show - -- backwards compatibility with the old data type dataDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations' = fmap (first Reference.DerivedId) . dataDeclarationsId' @@ -136,14 +92,6 @@ effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId' hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Term v a, Type v a) hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId --- {-# COMPLETE TypecheckedUnisonFile #-} --- pattern TypecheckedUnisonFile ds es tlcs wcs hts <- --- TypecheckedUnisonFileId (fmap (first Reference.DerivedId) -> ds) --- (fmap (first Reference.DerivedId) -> es) --- tlcs --- wcs --- (fmap (over _1 Reference.DerivedId) -> hts) - -- todo: this is confusing, right? -- currently: create a degenerate TypecheckedUnisonFile -- multiple definitions of "top-level components" non-watch vs w/ watch @@ -191,11 +139,6 @@ topLevelComponents :: TypecheckedUnisonFile v a topLevelComponents file = topLevelComponents' file ++ [ comp | (TestWatch, comp) <- watchComponents file ] -getDecl' :: Ord v => TypecheckedUnisonFile v a -> v -> Maybe (DD.Decl v a) -getDecl' uf v = - (Right . snd <$> Map.lookup v (dataDeclarations' uf)) <|> - (Left . snd <$> Map.lookup v (effectDeclarations' uf)) - -- External type references that appear in the types of the file's terms termSignatureExternalLabeledDependencies :: Ord v => TypecheckedUnisonFile v a -> Set LabeledDependency @@ -212,32 +155,6 @@ termSignatureExternalLabeledDependencies (map (LD.typeRef . fst) . toList) dataDeclarations' <> (map (LD.typeRef . fst) . toList) effectDeclarations') --- Returns a relation for the dependencies of this file. The domain is --- the dependent, and the range is its dependencies, thus: --- `R.lookupDom r (dependencies file)` returns the set of dependencies --- of the reference `r`. -dependencies' :: - forall v a. Var v => TypecheckedUnisonFile v a -> Relation Reference.Id Reference -dependencies' file = let - terms :: Map v (Reference.Id, Term v a, Type v a) - terms = hashTermsId file - decls :: Map v (Reference.Id, DataDeclaration v a) - decls = dataDeclarationsId' file <> - fmap (second toDataDecl) (effectDeclarationsId' file ) - termDeps = foldl' f Relation.empty $ toList terms - allDeps = foldl' g termDeps $ toList decls - f acc (r, tm, tp) = acc <> termDeps <> typeDeps - where termDeps = - Relation.fromList [ (r, dep) | dep <- toList (Term.dependencies tm)] - typeDeps = - Relation.fromList [ (r, dep) | dep <- toList (Type.dependencies tp)] - g acc (r, decl) = acc <> ctorDeps - where ctorDeps = - Relation.fromList [ (r, dep) | (_, _, tp) <- DD.constructors' decl - , dep <- toList (Type.dependencies tp) - ] - in allDeps - -- Returns the dependencies of the `UnisonFile` input. Needed so we can -- load information about these dependencies before starting typechecking. dependencies :: (Monoid a, Var v) => UnisonFile v a -> Set Reference @@ -259,9 +176,6 @@ declsToTypeLookup uf = TL.TypeLookup mempty (wrangle (effectDeclarations uf)) where wrangle = Map.fromList . Map.elems -typecheckedUnisonFile0 :: Ord v => TypecheckedUnisonFile v a -typecheckedUnisonFile0 = TypecheckedUnisonFileId Map.empty Map.empty mempty mempty mempty - -- Returns true if the file has any definitions or watches nonEmpty :: TypecheckedUnisonFile v a -> Bool nonEmpty uf = @@ -278,49 +192,3 @@ hashConstructors file = ctors2 = Map.elems (effectDeclarationsId' file) >>= \(ref, dd) -> [ (v, Referent.ConId ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] in Map.fromList (ctors1 ++ ctors2) - -type CtorLookup = Map String (Reference, Int) - --- Substitutes free type and term variables occurring in the terms of this --- `UnisonFile` using `externalNames`. --- --- Hash-qualified names are substituted during parsing, but non-HQ names are --- substituted at the end of parsing, since they can be locally bound. Example, in --- `x -> x + math.sqrt 2`, we don't know if `math.sqrt` is locally bound until --- we are done parsing, whereas `math.sqrt#abc` can be resolved immediately --- as it can't refer to a local definition. -bindNames :: Var v - => Names0 - -> UnisonFile v a - -> Names.ResolutionResult v a (UnisonFile v a) -bindNames names (UnisonFileId d e ts ws) = do - -- todo: consider having some kind of binding structure for terms & watches - -- so that you don't weirdly have free vars to tiptoe around. - -- The free vars should just be the things that need to be bound externally. - let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst) - termVarsSet = Set.fromList termVars - -- todo: can we clean up this lambda using something like `second` - ts' <- traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t) ts - ws' <- traverse (traverse (\(v,t) -> (v,) <$> Term.bindNames termVarsSet names t)) ws - pure $ UnisonFileId d e ts' ws' - -constructorType :: - Var v => UnisonFile v a -> Reference -> Maybe CT.ConstructorType -constructorType = TL.constructorType . declsToTypeLookup - --- data Error v a --- -- A free type variable that couldn't be resolved --- = UnknownType v a --- -- A variable which is both a data and an ability declaration --- | DupDataAndAbility v a a --- deriving (Eq,Ord,Show) - -allVars :: Ord v => UnisonFile v a -> Set v -allVars (UnisonFile ds es ts ws) = Set.unions - [ Map.keysSet ds - , foldMap (DD.allVars . snd) ds - , Map.keysSet es - , foldMap (DD.allVars . toDataDecl . snd) es - , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- ts ] - , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- join . Map.elems $ ws ] - ] \ No newline at end of file diff --git a/parser-typechecker/src/Unison/UnisonFile/Env.hs b/parser-typechecker/src/Unison/UnisonFile/Env.hs index 79a41e248d..d73bae5fe2 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Env.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Env.hs @@ -25,6 +25,3 @@ data Env v a = Env datas :: Env v a -> Map v (Reference, DataDeclaration v a) datas = fmap (first Reference.DerivedId) . datasId - -effects :: Env v a -> Map v (Reference, EffectDeclaration v a) -effects = fmap (first Reference.DerivedId) . effectsId diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index b882795012..231a527675 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -5,41 +5,27 @@ module Unison.UnisonFile.Names where -import Control.Lens -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Unison.ABT as ABT -import qualified Unison.Builtin.Decls as DD -import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..), hashDecls) import qualified Unison.DataDeclaration as DD import qualified Unison.DataDeclaration.Names as DD.Names -import Unison.LabeledDependency (LabeledDependency) -import qualified Unison.LabeledDependency as LD import qualified Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names import Unison.Names3 (Names0) import qualified Unison.Names3 as Names import Unison.Prelude -import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent -import Unison.Term (Term) import qualified Unison.Term as Term -import Unison.Type (Type) -import qualified Unison.Type as Type -import qualified Unison.Typechecker.TypeLookup as TL import Unison.UnisonFile.Env (Env(..)) import Unison.UnisonFile.Error (Error (UnknownType, DupDataAndAbility)) -import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId), pattern UnisonFile) +import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) import qualified Unison.UnisonFile as UF -import qualified Unison.UnisonFile.Error (pattern UnknownType, pattern DupDataAndAbility) -import qualified Unison.Util.List as List -import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as Relation import Unison.Var (Var) -import qualified Unison.Var as Var toNames :: Var v => UnisonFile v a -> Names0 toNames uf = datas <> effects diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 8c0ab889c6..90f6196402 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -38,39 +38,34 @@ where import Unison.Prelude -import Control.Lens (_3, over) +import Control.Lens (over, _3) import Control.Monad.State (evalState) - -import Data.Bifunctor (first, second, bimap) -import qualified Unison.Util.Relation as Rel -import Unison.Hash ( Hash ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding ( cycle ) -import Prelude.Extras ( Show1 ) -import qualified Unison.ABT as ABT -import Unison.Hashable ( Accumulate - , Hashable1 - ) +import Data.Bifunctor (bimap, first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import qualified Unison.ABT as ABT +import qualified Unison.ConstructorType as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) -import qualified Unison.Hashable as Hashable -import qualified Unison.Name as Name -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as Reference.Util -import qualified Unison.Referent as Referent -import qualified Unison.Term as Term -import Unison.Term ( Term ) +import Unison.Hash (Hash) +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Pattern as Pattern +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Reference.Util as Reference.Util +import qualified Unison.Referent as Referent import qualified Unison.Referent' as Referent' -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import qualified Unison.Type.Names as Type -import Unison.Var ( Var ) -import qualified Unison.Var as Var +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import Unison.Var (Var) +import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var -import qualified Unison.Names.ResolutionResult as Names -import qualified Unison.Pattern as Pattern -import qualified Unison.ConstructorType as CT +import Prelude hiding (cycle) type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) @@ -103,25 +98,12 @@ newtype EffectDeclaration v a = EffectDeclaration { toDataDecl :: DataDeclaration v a } deriving (Eq,Show,Functor) -withEffectDecl - :: (DataDeclaration v a -> DataDeclaration v' a') - -> (EffectDeclaration v a -> EffectDeclaration v' a') -withEffectDecl f e = EffectDeclaration (f . toDataDecl $ e) - withEffectDeclM :: Functor f => (DataDeclaration v a -> f (DataDeclaration v' a')) -> EffectDeclaration v a -> f (EffectDeclaration v' a') withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl -generateConstructorRefs - :: (Reference -> ConstructorId -> Reference) - -> Reference.Id - -> Int - -> [(ConstructorId, Reference)] -generateConstructorRefs hashCtor rid n = - (\i -> (i, hashCtor (Reference.DerivedId rid) i)) <$> [0 .. n] - generateRecordAccessors :: (Semigroup a, Var v) => [(v, a)] @@ -177,34 +159,6 @@ generateRecordAccessors fields typename typ = else Term.var ann v | ((v, _), j) <- fields `zip` [0..]] --- Returns references to the constructors, --- along with the terms for those references and their types. -constructorTerms - :: (Reference -> ConstructorId -> Reference) - -> (a -> Reference -> ConstructorId -> Term v a) - -> Reference.Id - -> DataDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -constructorTerms hashCtor f rid dd = - (\((a, _, t), (i, re@(Reference.DerivedId r))) -> (r, f a re i, t)) <$> zip - (constructors' dd) - (generateConstructorRefs hashCtor rid (length $ constructors dd)) - -dataConstructorTerms - :: Ord v - => Reference.Id - -> DataDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -dataConstructorTerms = constructorTerms Term.hashConstructor Term.constructor - -effectConstructorTerms - :: Ord v - => Reference.Id - -> EffectDeclaration v a - -> [(Reference.Id, Term v a, Type v a)] -effectConstructorTerms rid ed = - constructorTerms Term.hashRequest Term.request rid $ toDataDecl ed - constructorTypes :: DataDeclaration v a -> [Type v a] constructorTypes = (snd <$>) . constructors @@ -265,27 +219,14 @@ dependencies :: Ord v => DataDeclaration v a -> Set Reference dependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) -third :: (a -> b) -> (x,y,a) -> (x,y,b) -third f (x,y,a) = (x, y, f a) - mkEffectDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> EffectDeclaration v a mkEffectDecl' m a b cs = EffectDeclaration (DataDeclaration m a b cs) -mkEffectDecl :: Modifier -> [v] -> [(v, Type v ())] -> EffectDeclaration v () -mkEffectDecl m b cs = mkEffectDecl' m () b $ map (\(v, t) -> ((), v, t)) cs - mkDataDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> DataDeclaration v a mkDataDecl' = DataDeclaration -mkDataDecl :: Modifier -> [v] -> [(v, Type v ())] -> DataDeclaration v () -mkDataDecl m b cs = mkDataDecl' m () b $ map (\(v,t) -> ((),v,t)) cs - -constructorArities :: DataDeclaration v a -> [Int] -constructorArities (DataDeclaration _ _a _bound ctors) = - Type.arity . (\(_,_,t) -> t) <$> ctors - data F a = Type (Type.F a) | LetRec [a] a @@ -325,24 +266,6 @@ instance Hashable.Hashable Modifier where type Bar a f = Bar Long (Foo a) -} -hash :: (Eq v, Var v, Ord h, Accumulate h) - => [(v, ABT.Term F v ())] -> [(v, h)] -hash recursiveDecls = zip (fst <$> recursiveDecls) hashes where - hashes = ABT.hash <$> toLetRec recursiveDecls - -toLetRec :: Ord v => [(v, ABT.Term F v ())] -> [ABT.Term F v ()] -toLetRec decls = do1 <$> vs - where - (vs, decls') = unzip decls - -- we duplicate this letrec once (`do1`) - -- for each of the mutually recursive types - do1 v = ABT.cycle (ABT.absChain vs . ABT.tm $ LetRec decls' (ABT.var v)) - -unsafeUnwrapType :: (Var v) => ABT.Term F v a -> Type v a -unsafeUnwrapType typ = ABT.transform f typ - where f (Type t) = t - f _ = error $ "Tried to unwrap a type that wasn't a type: " ++ show typ - toABT :: Var v => DataDeclaration v () -> ABT.Term F v () toABT dd = ABT.tm $ Modified (modifier dd) dd' where diff --git a/unison-core/src/Unison/NameSegment.hs b/unison-core/src/Unison/NameSegment.hs index d649fd9fe1..42b1bf0fc9 100644 --- a/unison-core/src/Unison/NameSegment.hs +++ b/unison-core/src/Unison/NameSegment.hs @@ -6,8 +6,6 @@ import Unison.Prelude import qualified Data.Text as Text import qualified Unison.Hashable as H -import Unison.Util.Alphabetical (Alphabetical(compareAlphabetical)) - import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical) -- Represents the parts of a name between the `.`s diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index 29b53ca6cd..639a423635 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -70,16 +70,10 @@ toShortHash = \case Ref r -> R.toShortHash r Con r i _ -> patternShortHash r i -toShortHashId :: Id -> ShortHash -toShortHashId = toShortHash . fromId - -- also used by HashQualified.fromPattern patternShortHash :: Reference -> Int -> ShortHash patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } -showShort :: Int -> Referent -> Text -showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash - toText :: Referent -> Text toText = \case Ref r -> R.toText r @@ -95,32 +89,12 @@ pattern DataCtor = "d" toString :: Referent -> String toString = Text.unpack . toText -isConstructor :: Referent -> Bool -isConstructor Con{} = True -isConstructor _ = False - -toTermReference :: Referent -> Maybe Reference -toTermReference = \case - Ref r -> Just r - _ -> Nothing - toReference :: Referent -> Reference toReference = toReference' -fromId :: Id -> Referent -fromId = fmap R.DerivedId - -toTypeReference :: Referent -> Maybe Reference -toTypeReference = \case - Con r _i _t -> Just r - _ -> Nothing - isPrefixOf :: ShortHash -> Referent -> Bool isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) -unsafeFromText :: Text -> Referent -unsafeFromText = fromMaybe (error "invalid referent") . fromText - -- #abc[.xy][#cid] fromText :: Text -> Maybe Referent fromText t = either (const Nothing) Just $ diff --git a/unison-core/src/Unison/Type/Names.hs b/unison-core/src/Unison/Type/Names.hs index e3bdc5ddf7..f8a9ad69ff 100644 --- a/unison-core/src/Unison/Type/Names.hs +++ b/unison-core/src/Unison/Type/Names.hs @@ -10,23 +10,9 @@ module Unison.Type.Names where import Unison.Prelude import Unison.Type -import qualified Control.Monad.Writer.Strict as Writer -import Data.Functor.Identity (runIdentity) -import Data.Monoid (Any(..)) -import Data.List.Extra (nubOrd) -import qualified Data.Map as Map import qualified Data.Set as Set -import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) import qualified Unison.ABT as ABT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable -import qualified Unison.Kind as K -import Unison.Reference (Reference) -import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as ReferenceUtil -import Unison.Var (Var) -import qualified Unison.Var as Var -import qualified Unison.Settings as Settings +import Unison.Var (Var) import qualified Unison.Names3 as Names import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Name as Name From 0ce117ee9bbd4b81a5eb90b83ece8c5c4398a535 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 15:36:46 -0400 Subject: [PATCH 020/148] add two missing messages --- .../src/Unison/CommandLine/OutputMessages.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 2ce8717c7d..1b75cf7bbb 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -689,11 +689,12 @@ notifyUser dir o = case o of GitCouldntParseRootBranchHash repo s -> P.wrap $ "I couldn't parse the string" <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" <> P.group (prettyReadRepo repo <> ".") - -- CouldntLoadSyncedBranch h -> P.wrap $ "I just finished importing the branch" - -- <> P.red (P.shown h) <> "but now I can't find it." GitProtocolError e -> case e of NoGit -> P.wrap $ "I couldn't find git. Make sure it's installed and on your path." + CleanupError e -> P.wrap $ + "I encountered an exception while trying to clean up a git cache directory:" + <> P.group (P.shown e) CloneException repo msg -> P.wrap $ "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg @@ -729,6 +730,10 @@ notifyUser dir o = case o of $ "I couldn't load the designated root hash" <> P.group ("(" <> fromString (Hash.showBase32Hex hash) <> ")") <> "from the repository at" <> prettyReadRepo repo + CouldntLoadSyncedBranch ns h -> P.wrap + $ "I just finished importing the branch" <> P.red (P.shown h) + <> "from" <> P.red (prettyRemoteNamespace ns) + <> "but now I can't find it." NoRemoteNamespaceWithHash repo sbh -> P.wrap $ "The repository at" <> prettyReadRepo repo <> "doesn't contain a namespace with the hash prefix" From f52397b3d69a49a63e46d60a05cec8aacc944cea Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 15:48:03 -0400 Subject: [PATCH 021/148] fix warnings for `tests` project --- parser-typechecker/tests/Unison/Test/ABT.hs | 2 -- parser-typechecker/tests/Unison/Test/DataDeclaration.hs | 2 -- parser-typechecker/tests/Unison/Test/TypePrinter.hs | 1 - parser-typechecker/tests/Unison/Test/UnisonSources.hs | 9 --------- 4 files changed, 14 deletions(-) diff --git a/parser-typechecker/tests/Unison/Test/ABT.hs b/parser-typechecker/tests/Unison/Test/ABT.hs index 69daf20e1a..e32ddefac8 100644 --- a/parser-typechecker/tests/Unison/Test/ABT.hs +++ b/parser-typechecker/tests/Unison/Test/ABT.hs @@ -7,8 +7,6 @@ import EasyTest import Unison.ABT as ABT import Unison.Symbol (Symbol(..)) import Unison.Var as Var -import Unison.Codebase.Serialization ( getFromBytes, putBytes ) --- import qualified Unison.Codebase.FileCodebase.Serialization.V1 as V1 test :: Test () test = scope "abt" $ tests [ diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 4c72d6bc9f..613c549117 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -11,13 +11,11 @@ import Unison.DataDeclaration ( DataDeclaration(..), Decl, hashDecls import qualified Unison.Hash as Hash import Unison.Parser.Ann (Ann) import Unison.Parsers ( unsafeParseFile ) -import Unison.Reference (Reference) import qualified Unison.Reference as R import Unison.Symbol ( Symbol ) import qualified Unison.Test.Common as Common import qualified Unison.Type as Type import Unison.UnisonFile ( UnisonFile(..) ) -import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var diff --git a/parser-typechecker/tests/Unison/Test/TypePrinter.hs b/parser-typechecker/tests/Unison/Test/TypePrinter.hs index 7f7fea7fba..e3cfb6c3f8 100644 --- a/parser-typechecker/tests/Unison/Test/TypePrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TypePrinter.hs @@ -6,7 +6,6 @@ import Unison.TypePrinter import qualified Unison.Builtin import Unison.Util.ColorText (toPlain) import qualified Unison.Util.Pretty as PP -import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.Test.Common as Common diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 7deb3197cc..28d716ea9f 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -6,7 +6,6 @@ module Unison.Test.UnisonSources where import Control.Exception (throwIO) import Control.Lens ( view ) import Control.Lens.Tuple ( _5 ) -import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.Map as Map import Data.Sequence (Seq) @@ -16,30 +15,22 @@ import EasyTest import System.FilePath (joinPath, splitPath, replaceExtension) import System.FilePath.Find (always, extension, find, (==?)) import System.Directory ( doesFileExist ) -import qualified Unison.ABT as ABT import qualified Unison.Builtin as Builtin import Unison.Codebase.Runtime ( Runtime, evaluateWatches ) -import Unison.Codebase.Serialization ( getFromBytes, putBytes ) -import Unison.DataDeclaration (EffectDeclaration, DataDeclaration) -import Unison.Parser as Parser import Unison.Parser.Ann (Ann) import qualified Unison.Parsers as Parsers import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.PrintError as PrintError -import Unison.Reference ( Reference ) import Unison.Result (pattern Result, Result) import qualified Unison.Result as Result import qualified Unison.Runtime.Interface as RTI import Unison.Symbol (Symbol) import qualified Unison.Term as Term -import Unison.Term ( Term ) import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv) -import Unison.Type ( Type ) import qualified Unison.UnisonFile as UF import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty (toPlain) -import qualified Unison.Var as Var import qualified Unison.Test.Common as Common import qualified Unison.Names3 From 594264bb30110965e125023cf0532f1dbafa6812 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 30 Aug 2021 17:25:30 -0400 Subject: [PATCH 022/148] Avoid a loop caused by inferring cyclic abilities --- parser-typechecker/src/Unison/PrintError.hs | 24 +++++++++++ .../src/Unison/Typechecker/Context.hs | 17 +++++--- unison-src/transcripts/fix2355.md | 25 ++++++++++++ unison-src/transcripts/fix2355.output.md | 40 +++++++++++++++++++ 4 files changed, 100 insertions(+), 6 deletions(-) create mode 100644 unison-src/transcripts/fix2355.md create mode 100644 unison-src/transcripts/fix2355.output.md diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 1609f47869..a9db629906 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -363,6 +363,30 @@ renderTypeError e env src = case e of ] , debugSummary note ] + AbilityCheckFailure {..} + | [tv@(Type.Var' ev)] <- ambient + , ev `Set.member` foldMap Type.freeVars requested -> mconcat + [ "I tried to infer a cyclic ability." + , "\n\n" + , "The expression " + , describeStyle ErrorSite + , " was inferred to require the " + , case length requested of + 1 -> "ability: " + _ -> "abilities: " + , "\n\n {" + , commas (renderType' env) requested + , "}" + , "\n\n" + , "where `" + , renderType' env tv + , "` is its overall abilities." + , "\n\n" + , "I need a type signature to help figure this out." + , "\n\n" + , annotatedAsErrorSite src abilityCheckFailureSite + , debugSummary note + ] AbilityCheckFailure {..} | C.InSubtype{} :<| _ <- C.path note -> mconcat [ "The expression " diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 2313c5b8b6..c98616baa2 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -2109,11 +2109,16 @@ refineEffectVar -> [Type v loc] -> B.Blank loc -> v + -> Type v loc -> M v loc () -refineEffectVar _ es _ v +refineEffectVar _ es _ v _ | debugShow ("refineEffectVar", es, v) = undefined -refineEffectVar _ [] _ _ = pure () -refineEffectVar l es blank v = do +refineEffectVar _ [] _ _ _ = pure () +refineEffectVar l es blank v tv + | ev <- TypeVar.Existential blank v + , any (\e -> ev `Set.member` Type.freeVars e) es + = getContext >>= failWith . AbilityCheckFailure [tv] es + | otherwise = do slack <- freshenVar Var.inferAbility evs <- traverse (\e -> freshenVar (nameFrom Var.inferAbility e)) es let locs = loc <$> es @@ -2277,11 +2282,11 @@ subAbilities want have = do have <- expandAbilities have case (want , mapMaybe ex have) of ([], _) -> pure () - (want@((_, w):_), [(b, ve)]) -> - refineEffectVar (loc w) (snd <$> want) b ve -- `orElse` die src w + (want@((_, w):_), [(b, ve, tv)]) -> + refineEffectVar (loc w) (snd <$> want) b ve tv -- `orElse` die src w ((src, w):_, _) -> die src w where - ex (Type.Var' (TypeVar.Existential b v)) = Just (b, v) + ex t@(Type.Var' (TypeVar.Existential b v)) = Just (b, v, t) ex _ = Nothing die src w = maybe id (scope . InSynthesize) src do ctx <- getContext diff --git a/unison-src/transcripts/fix2355.md b/unison-src/transcripts/fix2355.md new file mode 100644 index 0000000000..25f4840b31 --- /dev/null +++ b/unison-src/transcripts/fix2355.md @@ -0,0 +1,25 @@ + +Tests for a loop that was previously occurring in the type checker. + +```ucm:hide +.> builtins.merge +``` + +```unison:error +structural ability A t g where + fork : '{g, A t g} a -> t a + await : t a -> a + empty! : t a + put : a -> t a -> () + +example : '{A t {}} Nat +example = 'let + r = A.empty! + go u = + t = A.fork '(go (u + 1)) + A.await t + + go 0 + t2 = A.fork '(A.put 10 r) + A.await r +``` diff --git a/unison-src/transcripts/fix2355.output.md b/unison-src/transcripts/fix2355.output.md new file mode 100644 index 0000000000..498f0fd949 --- /dev/null +++ b/unison-src/transcripts/fix2355.output.md @@ -0,0 +1,40 @@ + +Tests for a loop that was previously occurring in the type checker. + +```unison +structural ability A t g where + fork : '{g, A t g} a -> t a + await : t a -> a + empty! : t a + put : a -> t a -> () + +example : '{A t {}} Nat +example = 'let + r = A.empty! + go u = + t = A.fork '(go (u + 1)) + A.await t + + go 0 + t2 = A.fork '(A.put 10 r) + A.await r +``` + +```ucm + + I tried to infer a cyclic ability. + + The expression in red was inferred to require the ability: + + {A t25 {𝕖39, 𝕖18}} + + where `𝕖18` is its overall abilities. + + I need a type signature to properly figure this out. + + 10 | go u = + 11 | t = A.fork '(go (u + 1)) + 12 | A.await t + + +``` From f7746a4130a55299f9f76d6c12fb4e05889f10f3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 17:29:47 -0400 Subject: [PATCH 023/148] remove CodebaseFormat+parser from ArgParse and update messages --- .../src/Unison/Codebase/FileCodebase.hs | 22 +++++ .../unison-parser-typechecker.cabal | 1 + parser-typechecker/unison/ArgParse.hs | 14 ---- parser-typechecker/unison/Main.hs | 83 +++++++------------ 4 files changed, 55 insertions(+), 65 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/FileCodebase.hs diff --git a/parser-typechecker/src/Unison/Codebase/FileCodebase.hs b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs new file mode 100644 index 0000000000..2981b82a5c --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/FileCodebase.hs @@ -0,0 +1,22 @@ +module Unison.Codebase.FileCodebase (codebaseExists) where + +import System.FilePath (()) +import Unison.Codebase (CodebasePath) +import Unison.Prelude (MonadIO) +import UnliftIO.Directory (doesDirectoryExist) + +-- checks if a minimal codebase structure exists at `path` +codebaseExists :: MonadIO m => CodebasePath -> m Bool +codebaseExists root = + and <$> traverse doesDirectoryExist (minimalCodebaseStructure root) + + where + -- checks if `path` looks like a unison codebase + minimalCodebaseStructure :: CodebasePath -> [FilePath] + minimalCodebaseStructure root = [ branchHeadDir root ] + + branchesDir root = root codebasePath "paths" + branchHeadDir root = branchesDir root "_head" + + codebasePath :: FilePath + codebasePath = ".unison" "v1" diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 0ced79144f..8ee43dd277 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -56,6 +56,7 @@ library Unison.Codebase.Editor.UriParser Unison.Codebase.Editor.VersionParser Unison.Codebase.Execute + Unison.Codebase.FileCodebase Unison.Codebase.GitError Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError diff --git a/parser-typechecker/unison/ArgParse.hs b/parser-typechecker/unison/ArgParse.hs index 50a839c444..c64421f974 100644 --- a/parser-typechecker/unison/ArgParse.hs +++ b/parser-typechecker/unison/ArgParse.hs @@ -24,7 +24,6 @@ import Options.Applicative , command , customExecParser , flag - , flag' , footerDoc , fullDesc , headerDoc @@ -90,15 +89,9 @@ data Command | Transcript ShouldForkCodebase ShouldSaveCodebase (NonEmpty FilePath ) deriving (Show, Eq) -data CodebaseFormat - = V1 - | V2 - deriving (Show, Eq) - -- | Options shared by sufficiently many subcommands. data GlobalOptions = GlobalOptions { codebasePath :: Maybe FilePath - , codebaseFormat :: CodebaseFormat } deriving (Show, Eq) -- | The root-level 'ParserInfo'. @@ -201,7 +194,6 @@ commandParser envOpts = globalOptionsParser :: Parser GlobalOptions globalOptionsParser = do -- ApplicativeDo codebasePath <- codebasePathParser - codebaseFormat <- codebaseFormatParser pure GlobalOptions{..} codebasePathParser :: Parser (Maybe FilePath) @@ -211,12 +203,6 @@ codebasePathParser = <> metavar "path/to/codebase" <> help "The path to the codebase, defaults to the home directory" -codebaseFormatParser :: Parser CodebaseFormat -codebaseFormatParser = - flag' V1 (long "old-codebase" <> help "Use a v1 codebase on startup.") - <|> flag' V2 (long "new-codebase" <> help "Use a v2 codebase on startup.") - <|> pure V2 - launchHeadlessCommand :: CodebaseServerOpts -> Mod CommandFields Command launchHeadlessCommand envOpts = command "headless" (info (launchParser envOpts Headless) (progDesc headlessHelp)) diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 183f647816..d6ede49d85 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -27,6 +27,7 @@ import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) +import Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR @@ -44,8 +45,7 @@ import qualified Version import Compat ( installSignalHandlers ) import ArgParse ( UsageRenderer, - GlobalOptions(GlobalOptions, codebasePath, codebaseFormat), - CodebaseFormat(..), + GlobalOptions(GlobalOptions, codebasePath), Command(Launch, PrintVersion, Init, Run, Transcript), IsHeadless(WithCLI, Headless), ShouldSaveCodebase(..), @@ -55,9 +55,6 @@ import ArgParse import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann -cbInitFor = \case V2 -> SC.init - main :: IO () main = do progName <- getProgName @@ -65,8 +62,8 @@ main = do void installSignalHandlers (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribe - let GlobalOptions{codebasePath=mcodepath, codebaseFormat=cbFormat} = globalOptions - let cbInit = cbInitFor cbFormat + let GlobalOptions{codebasePath=mcodepath} = globalOptions + let cbInit = SC.init currentDir <- getCurrentDirectory configFilePath <- getConfigFilePath mcodepath config <- @@ -78,7 +75,7 @@ main = do Init -> Codebase.initCodebaseAndExit cbInit "main.init" mcodepath Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -89,7 +86,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing @@ -99,7 +96,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch @@ -108,9 +105,9 @@ main = do Nothing closeCodebase Transcript shouldFork shouldSaveCodebase transcriptFiles -> - runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveCodebase mcodepath transcriptFiles + runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mcodepath transcriptFiles Launch isHeadless codebaseServerOpts -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do PT.putPrettyLn $ P.lines @@ -131,13 +128,13 @@ main = do launch currentDir config runtime theCodebase [] (Just baseUrl) closeCodebase -prepareTranscriptDir :: CodebaseFormat -> ShouldForkCodebase -> Maybe FilePath -> IO FilePath -prepareTranscriptDir cbFormat shouldFork mcodepath = do +prepareTranscriptDir :: ShouldForkCodebase -> Maybe FilePath -> IO FilePath +prepareTranscriptDir shouldFork mcodepath = do tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript") - let cbInit = cbInitFor cbFormat + let cbInit = SC.init case shouldFork of UseFork -> do - getCodebaseOrExit cbFormat mcodepath + getCodebaseOrExit mcodepath path <- Codebase.getCodebaseDir mcodepath PT.putPrettyLn $ P.lines [ P.wrap "Transcript will be run on a copy of the codebase at: ", "", @@ -150,12 +147,11 @@ prepareTranscriptDir cbFormat shouldFork mcodepath = do pure tmp runTranscripts' - :: CodebaseFormat - -> Maybe FilePath + :: Maybe FilePath -> FilePath -> NonEmpty String -> IO Bool -runTranscripts' codebaseFormat mcodepath transcriptDir args = do +runTranscripts' mcodepath transcriptDir args = do currentDir <- getCurrentDirectory let (markdownFiles, invalidArgs) = NonEmpty.partition isMarkdown args for_ markdownFiles $ \fileName -> do @@ -168,7 +164,7 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do P.indentN 2 $ P.string err]) Right stanzas -> do configFilePath <- getConfigFilePath mcodepath - (closeCodebase, theCodebase) <- getCodebaseOrExit codebaseFormat $ Just transcriptDir + (closeCodebase, theCodebase) <- getCodebaseOrExit $ Just transcriptDir mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -189,17 +185,16 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do runTranscripts :: UsageRenderer - -> CodebaseFormat -> ShouldForkCodebase -> ShouldSaveCodebase -> Maybe FilePath -> NonEmpty String -> IO () -runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodepath args = do +runTranscripts renderUsageInfo shouldFork shouldSaveTempCodebase mcodepath args = do progName <- getProgName - transcriptDir <- prepareTranscriptDir cbFormat shouldFork mcodepath + transcriptDir <- prepareTranscriptDir shouldFork mcodepath completed <- - runTranscripts' cbFormat (Just transcriptDir) transcriptDir args + runTranscripts' (Just transcriptDir) transcriptDir args case shouldSaveTempCodebase of DontSaveCodebase -> removeDirectoryRecursive transcriptDir SaveCodebase -> @@ -262,9 +257,9 @@ defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) -- | load an existing codebase or exit. -getCodebaseOrExit :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebaseOrExit cbFormat mdir = do - let cbInit = cbInitFor cbFormat +getCodebaseOrExit :: Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) +getCodebaseOrExit mdir = do + let cbInit = SC.init dir <- Codebase.getCodebaseDir mdir Codebase.openCodebase cbInit "main" dir >>= \case Left _errRequestedVersion -> do @@ -273,11 +268,9 @@ getCodebaseOrExit cbFormat mdir = do suggestUpgrade = suggestUpgradeMessage <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir) prettyExe = P.text . Text.pack <$> getProgName prettyDir = P.string <$> canonicalizePath dir - PT.putPrettyLn' =<< case cbFormat of - V1 -> sayNoCodebase - V2 -> undefined >>= \case - Left {} -> sayNoCodebase - Right {} -> suggestUpgrade + PT.putPrettyLn' =<< (FC.codebaseExists dir >>= \case + False -> sayNoCodebase + True -> suggestUpgrade) Exit.exitFailure Right x -> pure x where @@ -301,10 +294,8 @@ getCodebaseOrExit cbFormat mdir = do suggestUpgradeMessage exec resolvedDir specifiedDir = P.lines ( P.wrap - <$> [ "I looked for a" <> prettyFmt V2 <> " codebase in " <> P.backticked' resolvedDir "," - <> "but found only a" - <> prettyFmt V1 - <> "codebase there.", + <$> [ "I looked for a v2 codebase in " <> P.backticked' resolvedDir "," + <> "but found only a v1 codebase there.", "", "You can use:" ] @@ -312,21 +303,11 @@ getCodebaseOrExit cbFormat mdir = do <> P.newline <> P.bulleted ( P.wrap - <$> [ P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "upgrade-codebase") - <> "to update it to" - <> P.group (prettyFmt V2 <> ","), - P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "init") - <> "to create a new" - <> prettyFmt V2 - <> "codebase alongside it, or", + <$> [ P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "init") + <> "to create a new v2 codebase alongside it, or", P.backticked (P.wrap $ exec <> "-codebase ") - <> "to load a" - <> prettyFmt V2 - <> "codebase from elsewhere." + <> "to load a v2 codebase from elsewhere, or", + "Use the M2g or M2h release of ucm to upgrade a v1 codebase;" + <> "they are available at https://github.com/unisonweb/unison/releases." ] ) - - - - prettyFmt :: IsString s => CodebaseFormat -> P.Pretty s - prettyFmt = \case V1 -> "v1"; V2 -> "v2" From fbbfbeb20c2aa1ede72e893ec08f60bc4ba2370e Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 30 Aug 2021 14:35:01 -0700 Subject: [PATCH 024/148] inits codebase if default does not exist --- parser-typechecker/src/Unison/Codebase.hs | 1 + .../src/Unison/Codebase/Init.hs | 43 +++++- parser-typechecker/unison/Main.hs | 132 ++++++++---------- 3 files changed, 95 insertions(+), 81 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 8a7453e587..c25ec8a8f7 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -187,6 +187,7 @@ debug = False data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward +-- Checkout out here. getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath getCodebaseDir = maybe getHomeDirectory pure diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 85a85e4e90..a556c0c60d 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -6,6 +6,7 @@ module Unison.Codebase.Init where import System.Exit (exitFailure) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase +import qualified Unison.Codebase.FileCodebase.Common as FCC import Unison.Parser (Ann) import Unison.Prelude import qualified Unison.PrettyTerminal as PT @@ -31,10 +32,44 @@ data Init m v a = Init codebasePath :: CodebasePath -> CodebasePath } +type FinalizerAndCodebase m v a = (m (), Codebase m v a) + +data InitError + = NoCodebaseFoundAtSpecifiedDir + | FoundV1Codebase + | CouldntCreateCodebase Pretty + +data InitResult m v a + = OpenedCodebase CodebasePath (FinalizerAndCodebase m v a) + | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) + | Error CodebasePath InitError + +openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> Maybe CodebasePath -> m (InitResult m v a) +openOrCreateCodebase cbInit debugName maybeSpecificedDir = do + resolvedDir <- Codebase.getCodebaseDir maybeSpecificedDir + openCodebase cbInit debugName resolvedDir >>= \case -- calls accessor function Init -> debug name -> blah blah + Right cb -> pure (OpenedCodebase resolvedDir cb) + Left _ -> + case maybeSpecificedDir of + Nothing -> do + ifM (FCC.codebaseExists resolvedDir) + (do pure (Error resolvedDir FoundV1Codebase)) + (do + -- Create V2 codebase if neither a V1 or V2 exists + createCodebase cbInit debugName resolvedDir >>= \case + Left errorMessage -> do pure (Error resolvedDir (CouldntCreateCodebase errorMessage)) + Right cb -> do + pure (CreatedCodebase resolvedDir cb) + ) + Just specifiedDir -> do + ifM (FCC.codebaseExists specifiedDir) + (pure (Error specifiedDir FoundV1Codebase)) + (pure (Error specifiedDir NoCodebaseFoundAtSpecifiedDir)) + createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)) -createCodebase debugName cbInit path = do +createCodebase cbInit debugName path = do prettyDir <- P.string <$> canonicalizePath path - createCodebase' debugName cbInit path <&> mapLeft \case + createCodebase' cbInit debugName path <&> mapLeft \case CreateCodebaseAlreadyExists -> P.wrap $ "It looks like there's already a codebase in: " @@ -52,9 +87,9 @@ createCodebase debugName cbInit path = do -- previously: initCodebaseOrExit :: CodebasePath -> m (m (), Codebase m v a) -- previously: FileCodebase.initCodebase :: CodebasePath -> m (m (), Codebase m v a) openNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> m (m (), Codebase m Symbol Ann) -openNewUcmCodebaseOrExit debugName cbInit path = do +openNewUcmCodebaseOrExit cbInit debugName path = do prettyDir <- P.string <$> canonicalizePath path - createCodebase debugName cbInit path >>= \case + createCodebase cbInit debugName path >>= \case Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure Right x@(_, codebase) -> do liftIO $ diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 9026d9ef0f..67acdafe7f 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -22,7 +22,8 @@ import qualified System.IO.Temp as Temp import qualified System.Path as Path import Text.Megaparsec (runParser) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Init as Codebase +import Unison.Codebase.Init (InitResult(..), InitError(..)) +import qualified Unison.Codebase.Init as CodebaseInit import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP @@ -58,7 +59,7 @@ import ArgParse import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann +cbInitFor :: CodebaseFormat -> CodebaseInit.Init IO Symbol Ann cbInitFor = \case V1 -> FC.init; V2 -> SC.init main :: IO () @@ -79,9 +80,9 @@ main = do PrintVersion -> putStrLn $ progName ++ " version: " ++ Version.gitDescribe Init -> - Codebase.initCodebaseAndExit cbInit "main.init" mcodepath + CodebaseInit.initCodebaseAndExit cbInit "main.init" mcodepath Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -92,7 +93,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing @@ -102,7 +103,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch @@ -114,7 +115,7 @@ main = do runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveCodebase mcodepath transcriptFiles UpgradeCodebase -> upgradeCodebase mcodepath Launch isHeadless codebaseServerOpts -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do PT.putPrettyLn $ P.lines @@ -147,7 +148,7 @@ upgradeCodebase mcodepath = $ P.newline <> "Try it out and once you're satisfied, you can safely(?) delete the old version from" <> P.newline - <> P.indentN 2 (P.string $ Codebase.codebasePath (FC.init @IO) root) + <> P.indentN 2 (P.string $ CodebaseInit.codebasePath (FC.init @IO) root) <> P.newline <> "but there's no rush. You can access the old codebase again by passing the" <> P.backticked "--old-codebase" <> "flag at startup." @@ -158,16 +159,16 @@ prepareTranscriptDir cbFormat shouldFork mcodepath = do let cbInit = cbInitFor cbFormat case shouldFork of UseFork -> do - getCodebaseOrExit cbFormat mcodepath + getCodebase cbFormat mcodepath path <- Codebase.getCodebaseDir mcodepath PT.putPrettyLn $ P.lines [ P.wrap "Transcript will be run on a copy of the codebase at: ", "", P.indentN 2 (P.string path) ] - Path.copyDir (Codebase.codebasePath cbInit path) (Codebase.codebasePath cbInit tmp) + Path.copyDir (CodebaseInit.codebasePath cbInit path) (CodebaseInit.codebasePath cbInit tmp) DontFork -> do PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase." - void $ Codebase.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp + void $ CodebaseInit.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp pure tmp runTranscripts' @@ -189,7 +190,7 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do P.indentN 2 $ P.string err]) Right stanzas -> do configFilePath <- getConfigFilePath mcodepath - (closeCodebase, theCodebase) <- getCodebaseOrExit codebaseFormat $ Just transcriptDir + (closeCodebase, theCodebase) <- getCodebase codebaseFormat $ Just transcriptDir mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -282,72 +283,49 @@ defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) --- | load an existing codebase or exit. -getCodebaseOrExit :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebaseOrExit cbFormat mdir = do - let cbInit = cbInitFor cbFormat - dir <- Codebase.getCodebaseDir mdir - Codebase.openCodebase cbInit "main" dir >>= \case - Left _errRequestedVersion -> do +getCodebase :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) +getCodebase cbFormat maybeSpecifiedDir = + -- Likely we should only change codebase format 2? Or both? + -- Notes for selves: create a function 'openOrCreateCodebase' which handles v1/v2 codebase provided / no codebase specified + -- encode error messages as types. Our spike / idea is below: + CodebaseInit.openOrCreateCodebase (cbInitFor cbFormat) "main" maybeSpecifiedDir >>= \case + Error dir error -> let - sayNoCodebase = noCodebaseMsg <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir) - suggestUpgrade = suggestUpgradeMessage <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir) - prettyExe = P.text . Text.pack <$> getProgName - prettyDir = P.string <$> canonicalizePath dir - PT.putPrettyLn' =<< case cbFormat of - V1 -> sayNoCodebase - V2 -> FC.openCodebase dir >>= \case - Left {} -> sayNoCodebase - Right {} -> suggestUpgrade - Exit.exitFailure - Right x -> pure x - where - noCodebaseMsg :: _ - noCodebaseMsg executable prettyDir mdir = - let secondLine = - case mdir of - Just dir -> - "Run `" <> executable <> " -codebase " <> dir - <> " init` to create one, then try again!" - Nothing -> - "Run `" <> executable <> " init` to create one there," - <> " then try again;" - <> " or `" - <> executable - <> " -codebase ` to load a codebase from someplace else!" - in P.lines - [ "No codebase exists in " <> prettyDir <> ".", - secondLine - ] - suggestUpgradeMessage exec resolvedDir specifiedDir = - P.lines - ( P.wrap - <$> [ "I looked for a" <> prettyFmt V2 <> " codebase in " <> P.backticked' resolvedDir "," - <> "but found only a" - <> prettyFmt V1 - <> "codebase there.", - "", - "You can use:" - ] - ) - <> P.newline - <> P.bulleted - ( P.wrap - <$> [ P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "upgrade-codebase") - <> "to update it to" - <> P.group (prettyFmt V2 <> ","), - P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "init") - <> "to create a new" - <> prettyFmt V2 - <> "codebase alongside it, or", - P.backticked (P.wrap $ exec <> "-codebase ") - <> "to load a" - <> prettyFmt V2 - <> "codebase from elsewhere." - ] - ) + message = do + pDir <- prettyDir dir + executableName <- P.text . Text.pack <$> getProgName + + case error of + NoCodebaseFoundAtSpecifiedDir -> + -- TODO: Perhaps prompt the user to create a codebase in that directory right away? + pure (P.lines + [ "No codebase exists in " <> pDir <> ".", + "Run `" <> executableName <> " --codebase " <> P.string dir <> " init` to create one, then try again!" + ]) + FoundV1Codebase -> + pure (P.lines + [ "Found a v1 codebase at " <> pDir <> ".", + "v1 codebases are no longer supported in this version of the UCM.", + "Please download version M2g of the UCM to upgrade." + ]) + CouldntCreateCodebase errMessage -> + pure errMessage - prettyFmt :: IsString s => CodebaseFormat -> P.Pretty s - prettyFmt = \case V1 -> "v1"; V2 -> "v2" + in do + msg <- message + PT.putPrettyLn' msg + Exit.exitFailure + + CreatedCodebase dir cb -> do + pDir <- prettyDir dir + PT.putPrettyLn' "" + PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> pDir + pure cb + + OpenedCodebase _ cb -> + pure cb + + where + prettyDir dir = P.string <$> canonicalizePath dir \ No newline at end of file From f597506156fb7996b5438bf02304fcb0c5c67b8e Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 30 Aug 2021 14:41:13 -0700 Subject: [PATCH 025/148] removed codebase format in getCodebase --- parser-typechecker/unison/Main.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 67acdafe7f..264aa21da3 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -82,7 +82,7 @@ main = do Init -> CodebaseInit.initCodebaseAndExit cbInit "main.init" mcodepath Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase mcodepath runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -93,7 +93,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing @@ -103,7 +103,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase mcodepath rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch @@ -115,7 +115,7 @@ main = do runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveCodebase mcodepath transcriptFiles UpgradeCodebase -> upgradeCodebase mcodepath Launch isHeadless codebaseServerOpts -> do - (closeCodebase, theCodebase) <- getCodebase cbFormat mcodepath + (closeCodebase, theCodebase) <- getCodebase mcodepath runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do PT.putPrettyLn $ P.lines @@ -159,7 +159,7 @@ prepareTranscriptDir cbFormat shouldFork mcodepath = do let cbInit = cbInitFor cbFormat case shouldFork of UseFork -> do - getCodebase cbFormat mcodepath + getCodebase mcodepath path <- Codebase.getCodebaseDir mcodepath PT.putPrettyLn $ P.lines [ P.wrap "Transcript will be run on a copy of the codebase at: ", "", @@ -172,12 +172,11 @@ prepareTranscriptDir cbFormat shouldFork mcodepath = do pure tmp runTranscripts' - :: CodebaseFormat - -> Maybe FilePath + :: Maybe FilePath -> FilePath -> NonEmpty String -> IO Bool -runTranscripts' codebaseFormat mcodepath transcriptDir args = do +runTranscripts' mcodepath transcriptDir args = do currentDir <- getCurrentDirectory let (markdownFiles, invalidArgs) = NonEmpty.partition isMarkdown args for_ markdownFiles $ \fileName -> do @@ -190,7 +189,7 @@ runTranscripts' codebaseFormat mcodepath transcriptDir args = do P.indentN 2 $ P.string err]) Right stanzas -> do configFilePath <- getConfigFilePath mcodepath - (closeCodebase, theCodebase) <- getCodebase codebaseFormat $ Just transcriptDir + (closeCodebase, theCodebase) <- getCodebase $ Just transcriptDir mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -221,7 +220,7 @@ runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodep progName <- getProgName transcriptDir <- prepareTranscriptDir cbFormat shouldFork mcodepath completed <- - runTranscripts' cbFormat (Just transcriptDir) transcriptDir args + runTranscripts' (Just transcriptDir) transcriptDir args case shouldSaveTempCodebase of DontSaveCodebase -> removeDirectoryRecursive transcriptDir SaveCodebase -> @@ -233,7 +232,7 @@ runTranscripts renderUsageInfo cbFormat shouldFork shouldSaveTempCodebase mcodep "I've finished running the transcript(s) in this codebase:", "", P.indentN 2 (P.string transcriptDir), "", P.wrap $ "You can run" - <> P.backticked (P.string progName <> " -codebase " <> P.string transcriptDir) + <> P.backticked (P.string progName <> " --codebase " <> P.string transcriptDir) <> "to do more work with it."]) else do putStrLn (renderUsageInfo $ Just "transcript") @@ -283,12 +282,12 @@ defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) -getCodebase :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebase cbFormat maybeSpecifiedDir = +getCodebase :: Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) +getCodebase maybeSpecifiedDir = -- Likely we should only change codebase format 2? Or both? -- Notes for selves: create a function 'openOrCreateCodebase' which handles v1/v2 codebase provided / no codebase specified -- encode error messages as types. Our spike / idea is below: - CodebaseInit.openOrCreateCodebase (cbInitFor cbFormat) "main" maybeSpecifiedDir >>= \case + CodebaseInit.openOrCreateCodebase SC.init "main" maybeSpecifiedDir >>= \case Error dir error -> let message = do From cafb89f0b91fb03f0d9c98a89e35f5907b3bd8d7 Mon Sep 17 00:00:00 2001 From: Rebecca Date: Mon, 30 Aug 2021 14:43:52 -0700 Subject: [PATCH 026/148] Update Codebase.hs --- parser-typechecker/src/Unison/Codebase.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index c25ec8a8f7..8a7453e587 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -187,7 +187,6 @@ debug = False data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward --- Checkout out here. getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath getCodebaseDir = maybe getHomeDirectory pure From 81a32fc8941d582fc73afd9fa1cee7ba99ec18c5 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 20:24:46 -0400 Subject: [PATCH 027/148] formatting and deleting commented-out code --- parser-typechecker/src/Unison/Codebase.hs | 63 +- .../src/Unison/Codebase/Branch.hs | 115 ---- .../src/Unison/Codebase/Branch/Names.hs | 644 +----------------- .../src/Unison/Codebase/BuiltinAnnotation.hs | 2 +- .../Codebase/SqliteCodebase/GitError.hs | 2 +- .../src/Unison/Codebase/Type.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 8 - .../src/Unison/PrettyPrintEnv/Util.hs | 105 +-- parser-typechecker/src/Unison/Server/Doc.hs | 8 +- parser-typechecker/src/Unison/TermPrinter.hs | 94 +-- .../src/Unison/UnisonFile/Names.hs | 10 - parser-typechecker/tests/Unison/Test/Ucm.hs | 4 - .../Unison/DataDeclaration/ConstructorId.hs | 2 +- unison-core/src/Unison/Type/Names.hs | 2 +- unison-core/src/Unison/Var.hs | 7 +- unison-core/src/Unison/Var/RefNamed.hs | 2 +- 16 files changed, 79 insertions(+), 991 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index f866739581..bf3f05022c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -93,36 +93,9 @@ lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = case lcaImpl co Nothing -> pure Nothing -- no common ancestor else Branch.lca b1 b2 --- before :: Monad m => Codebase m v a -> Branch m -> Branch m -> m Bool --- before code b1 b2 = case beforeImpl code of --- Nothing -> Branch.before b1 b2 --- Just before -> before' (branchExists code) before b1 b2 - --- before' :: Monad m => (Branch.Hash -> m Bool) -> (Branch.Hash -> Branch.Hash -> m Bool) -> Branch m -> Branch m -> m Bool --- before' branchExists before b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = --- ifM --- (branchExists h2) --- (ifM --- (branchExists h2) --- (before h1 h2) --- (pure False)) --- (Branch.before b1 b2) - - --- data GetRootBranchError --- = NoRootBranch --- | CouldntParseRootBranch String --- | CouldntLoadRootBranch Branch.Hash --- deriving Show - debug :: Bool debug = False --- data SyncFileCodebaseResult = SyncOk | UnknownDestinationRootBranch Branch.Hash | NotFastForward - --- getCodebaseDir :: MonadIO m => Maybe FilePath -> m FilePath --- getCodebaseDir = maybe getHomeDirectory pure - -- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m () installUcmDependencies c = do @@ -182,32 +155,6 @@ typeLookupForDependencies codebase s = do Nothing -> pure mempty go tl Reference.Builtin{} = pure tl -- codebase isn't consulted for builtins --- -- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? --- -- todo: add some tests on this guy? --- transitiveDependencies --- :: (Monad m, Var v) --- => CL.CodeLookup v m a --- -> Set Reference.Id --- -> Reference.Id --- -> m (Set Reference.Id) --- transitiveDependencies code seen0 rid = if Set.member rid seen0 --- then pure seen0 --- else --- let seen = Set.insert rid seen0 --- getIds = Set.mapMaybe Reference.toId --- in CL.getTerm code rid >>= \case --- Just t -> --- foldM (transitiveDependencies code) seen (getIds $ Term.dependencies t) --- Nothing -> --- CL.getTypeDeclaration code rid >>= \case --- Nothing -> pure seen --- Just (Left ed) -> foldM (transitiveDependencies code) --- seen --- (getIds $ DD.dependencies (DD.toDataDecl ed)) --- Just (Right dd) -> foldM (transitiveDependencies code) --- seen --- (getIds $ DD.dependencies dd) - toCodeLookup :: Codebase m v a -> CL.CodeLookup v m a toCodeLookup c = CL.CodeLookup (getTerm c) (getTypeDeclaration c) @@ -260,13 +207,7 @@ isType c r = case r of Reference.Builtin{} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r --- class BuiltinAnnotation a where --- builtinAnnotation :: a - --- instance BuiltinAnnotation Parser.Ann where --- builtinAnnotation = Parser.Intrinsic - --- -- * Git stuff +-- * Git stuff -- | Sync elements as needed from a remote codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; @@ -298,4 +239,4 @@ viewRemoteBranch :: m (Either GitError (m (), Branch m)) viewRemoteBranch codebase ns = runExceptT do (cleanup, branch, _) <- ExceptT $ viewRemoteBranch' codebase ns - pure (cleanup, branch) \ No newline at end of file + pure (cleanup, branch) diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 0143a1abda..5fbb1d5e99 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -265,15 +265,6 @@ discardHistory0 :: Applicative m => Branch0 m -> Branch0 m discardHistory0 = over children (fmap tweak) where tweak b = cons (discardHistory0 (head b)) empty - --- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- -- It's defined as: lca b1 b2 == Just b1 --- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) --- -> Branch m -> Branch m -> m Bool --- before' lca (Branch x) (Branch y) = Causal.before' lca' x y --- where --- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - -- `before b1 b2` is true if `b2` incorporates all of `b1` before :: Monad m => Branch m -> Branch m -> m Bool before (Branch b1) (Branch b2) = Causal.before b1 b2 @@ -286,39 +277,16 @@ toList0 = go Path.empty where go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> go (Path.snoc p seg) (head cb) )) --- printDebugPaths :: Branch m -> String --- printDebugPaths = unlines . map show . Set.toList . debugPaths - --- debugPaths :: Branch m -> Set (Path, Hash) --- debugPaths = go Path.empty where --- go p b = Set.insert (p, headHash b) . Set.unions $ --- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] - --- data Target = TargetType | TargetTerm | TargetBranch --- deriving (Eq, Ord, Show) - instance Eq (Branch0 m) where a == b = view terms a == view terms b && view types a == view types b && view children a == view children b && (fmap fst . view edits) a == (fmap fst . view edits) b --- data ForkFailure = SrcNotFound | DestExists - --- -- consider delegating to Names.numHashChars when ready to implement? --- -- are those enough? --- -- could move this to a read-only field in Branch0 --- -- could move a Names0 to a read-only field in Branch0 until it gets too big --- numHashChars :: Branch m -> Int --- numHashChars _b = 3 - -- This type is a little ugly, so we wrap it up with a nice type alias for -- use outside this module. type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) --- boundedCache :: MonadIO m => Word -> m (Cache m2) --- boundedCache = Cache.semispaceCache - -- Can use `Cache.nullCache` to disable caching if needed cachedRead :: forall m . MonadIO m => Cache m @@ -399,52 +367,6 @@ toCausalRaw = \case Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) --- -- copy a path to another path --- fork --- :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- fork src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> case setIfNotExists dest src' root of --- Nothing -> Left DestExists --- Just root' -> Right root' - --- -- Move the node at src to dest. --- -- It's okay if `dest` is inside `src`, just create empty levels. --- -- Try not to `step` more than once at each node. --- move :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- move src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> --- -- make sure dest doesn't already exist --- case getAt dest root of --- Just _destExists -> Left DestExists --- Nothing -> --- -- find and update common ancestor of `src` and `dest`: --- Right $ modifyAt ancestor go root --- where --- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest --- go = deleteAt relSrc . setAt relDest src' - --- setIfNotExists --- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) --- setIfNotExists dest b root = case getAt dest root of --- Just _destExists -> Nothing --- Nothing -> Just $ setAt dest b root - --- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m --- setAt path b = modifyAt path (const b) - --- deleteAt :: Applicative m => Path -> Branch m -> Branch m --- deleteAt path = setAt path empty - -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` getAt :: Path -> Branch m @@ -629,10 +551,6 @@ instance Hashable (Branch0 m) where , H.accumulateToken (fst <$> _edits b) ] --- getLocalBranch :: Hash -> IO Branch --- getGithubBranch :: RemotePath -> IO Branch --- getLocalEdit :: GUID -> IO Patch - -- todo: consider inlining these into Actions2 addTermName :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m @@ -644,9 +562,6 @@ addTypeName addTypeName r new md = over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) --- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m --- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m - deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) = over terms (Star3.deletePrimaryD1 (r,n)) b @@ -657,9 +572,6 @@ deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) = over types (Star3.deletePrimaryD1 (r,n)) b deleteTypeName _ _ b = b --- namesDiff :: Branch m -> Branch m -> Names.Diff --- namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) - lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b @@ -694,30 +606,3 @@ transform f b = case _history b of -> Causal m Raw (Branch0 m) -> Causal m Raw (Branch0 n) transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) - --- data BranchAttentions = BranchAttentions --- { -- Patches that were edited on the right but entirely removed on the left. --- removedPatchEdited :: [Name] --- -- Patches that were edited on the left but entirely removed on the right. --- , editedPatchRemoved :: [Name] --- } - --- instance Semigroup BranchAttentions where --- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 --- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - --- instance Monoid BranchAttentions where --- mempty = BranchAttentions [] [] --- mappend = (<>) - --- data RefCollisions = --- RefCollisions { termCollisions :: Relation Name Name --- , typeCollisions :: Relation Name Name --- } deriving (Eq, Show) - --- instance Semigroup RefCollisions where --- (<>) = mappend --- instance Monoid RefCollisions where --- mempty = RefCollisions mempty mempty --- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) --- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs index c45e1b66ee..0667b7ffe8 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Names.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Names.hs @@ -13,10 +13,6 @@ module Unison.Codebase.Branch.Names ) where -import Unison.Prelude hiding (empty) - -import Prelude hiding (head,read,subtract) - import qualified Data.Set as Set import Unison.Codebase.Branch import qualified Unison.Codebase.Causal.FoldHistory as Causal @@ -28,10 +24,12 @@ import Unison.Name (Name (..)) import Unison.Names2 (Names' (Names), Names0) import qualified Unison.Names2 as Names import qualified Unison.Names3 as Names +import Unison.Prelude hiding (empty) import Unison.Reference (Reference) import Unison.Referent (Referent) import qualified Unison.Referent as Referent import qualified Unison.Util.Relation as R +import Prelude hiding (head, read, subtract) toNames0 :: Branch0 m -> Names0 toNames0 b = Names (R.swap . deepTerms $ b) @@ -88,643 +86,5 @@ findInHistory termMatches typeMatches queries b = doType q acc@(remainingSHs, names0) (r, n) = if typeMatches q r n then (Set.delete q remainingSHs, Names.addType n r names0) else acc --- deepReferents :: Branch0 m -> Set Referent --- deepReferents = R.dom . deepTerms - --- deepTypeReferences :: Branch0 m -> Set Reference --- deepTypeReferences = R.dom . deepTypes - --- terms :: Lens' (Branch0 m) (Star Referent NameSegment) --- terms = lens _terms (\Branch0{..} x -> branch0 x _types _children _edits) - --- types :: Lens' (Branch0 m) (Star Reference NameSegment) --- types = lens _types (\Branch0{..} x -> branch0 _terms x _children _edits) - --- children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) --- children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits) - --- -- -- creates a Branch0 from the primary fields and derives the others. --- -- branch0 :: Metadata.Star Referent NameSegment --- -- -> Metadata.Star Reference NameSegment --- -- -> Map NameSegment (Branch m) --- -- -> Map NameSegment (EditHash, m Patch) --- -- -> Branch0 m --- -- branch0 terms types children edits = --- -- Branch0 terms types children edits --- -- deepTerms' deepTypes' --- -- deepTermMetadata' deepTypeMetadata' --- -- deepPaths' deepEdits' --- -- where --- -- nameSegToName = Name.unsafeFromText . NameSegment.toText --- -- deepTerms' = (R.mapRan nameSegToName . Star3.d1) terms --- -- <> foldMap go (Map.toList children) --- -- where --- -- go (nameSegToName -> n, b) = --- -- R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic --- -- deepTypes' = (R.mapRan nameSegToName . Star3.d1) types --- -- <> foldMap go (Map.toList children) --- -- where --- -- go (nameSegToName -> n, b) = --- -- R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic --- -- deepTermMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 terms) --- -- <> foldMap go (Map.toList children) --- -- where --- -- go (nameSegToName -> n, b) = --- -- R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b) --- -- deepTypeMetadata' = R4.mapD2 nameSegToName (Metadata.starToR4 types) --- -- <> foldMap go (Map.toList children) --- -- where --- -- go (nameSegToName -> n, b) = --- -- R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b) --- -- deepPaths' = Set.map Path.singleton (Map.keysSet children) --- -- <> foldMap go (Map.toList children) --- -- where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b) --- -- deepEdits' = Map.mapKeys nameSegToName (Map.map fst edits) --- -- <> foldMap go (Map.toList children) --- -- where --- -- go (nameSeg, b) = --- -- Map.mapKeys (nameSegToName nameSeg `Name.joinDot`) . deepEdits $ head b - --- -- head :: Branch m -> Branch0 m --- -- head (Branch c) = Causal.head c - --- headHash :: Branch m -> Hash --- headHash (Branch c) = Causal.currentHash c - --- deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch) --- deepEdits' b = go id b where --- -- can change this to an actual prefix once Name is a [NameSegment] --- go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch) --- go addPrefix Branch0{..} = --- Map.mapKeysMonotonic (addPrefix . Name.fromSegment) _edits --- <> foldMap f (Map.toList _children) --- where --- f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch) --- f (c, b) = go (addPrefix . Name.joinDot (Name.fromSegment c)) (head b) - --- data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show) - --- merge :: forall m . Monad m => Branch m -> Branch m -> m (Branch m) --- merge = merge' RegularMerge - --- -- Discards the history of a Branch0's children, recursively --- discardHistory0 :: Applicative m => Branch0 m -> Branch0 m --- discardHistory0 = over children (fmap tweak) where --- tweak b = cons (discardHistory0 (head b)) empty - --- merge' :: forall m . Monad m => MergeMode -> Branch m -> Branch m -> m (Branch m) --- merge' = merge'' lca - --- merge'' :: forall m . Monad m --- => (Branch m -> Branch m -> m (Maybe (Branch m))) -- lca calculator --- -> MergeMode --- -> Branch m --- -> Branch m --- -> m (Branch m) --- merge'' _ _ b1 b2 | isEmpty b1 = pure b2 --- merge'' _ mode b1 b2 | isEmpty b2 = case mode of --- RegularMerge -> pure b1 --- SquashMerge -> pure $ cons (discardHistory0 (head b1)) b2 --- merge'' lca mode (Branch x) (Branch y) = --- Branch <$> case mode of --- RegularMerge -> Causal.threeWayMerge' lca' combine x y --- SquashMerge -> Causal.squashMerge' lca' (pure . discardHistory0) combine x y --- where --- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) --- combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m) --- combine Nothing l r = merge0 lca mode l r --- combine (Just ca) l r = do --- dl <- diff0 ca l --- dr <- diff0 ca r --- head0 <- apply ca (dl <> dr) --- children <- Map.mergeA --- (Map.traverseMaybeMissing $ combineMissing ca) --- (Map.traverseMaybeMissing $ combineMissing ca) --- (Map.zipWithAMatched $ const (merge'' lca mode)) --- (_children l) (_children r) --- pure $ branch0 (_terms head0) (_types head0) children (_edits head0) - --- combineMissing ca k cur = --- case Map.lookup k (_children ca) of --- Nothing -> pure $ Just cur --- Just old -> do --- nw <- merge'' lca mode (cons empty0 old) cur --- if isEmpty0 $ head nw --- then pure Nothing --- else pure $ Just nw - --- apply :: Branch0 m -> BranchDiff -> m (Branch0 m) --- apply b0 BranchDiff {..} = do --- patches <- sequenceA --- $ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches --- let newPatches = makePatch <$> Map.difference changedPatches (_edits b0) --- makePatch Patch.PatchDiff {..} = --- let p = Patch.Patch _addedTermEdits _addedTypeEdits --- in (H.accumulate' p, pure p) --- pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms) --- (Star3.difference (_types b0) removedTypes <> addedTypes) --- (_children b0) --- (patches <> newPatches) --- patchMerge mhp Patch.PatchDiff {..} = Just $ do --- (_, mp) <- mhp --- p <- mp --- let np = Patch.Patch --- { _termEdits = R.difference (Patch._termEdits p) _removedTermEdits --- <> _addedTermEdits --- , _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits --- <> _addedTypeEdits --- } --- pure (H.accumulate' np, pure np) - --- -- `before' lca b1 b2` is true if `b2` incorporates all of `b1` --- -- It's defined as: lca b1 b2 == Just b1 --- before' :: Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) --- -> Branch m -> Branch m -> m Bool --- before' lca (Branch x) (Branch y) = Causal.before' lca' x y --- where --- lca' c1 c2 = fmap _history <$> lca (Branch c1) (Branch c2) - --- -- `before b1 b2` is true if `b2` incorporates all of `b1` --- before :: Monad m => Branch m -> Branch m -> m Bool --- before (Branch b1) (Branch b2) = Causal.before b1 b2 - --- merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m))) --- -> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m) --- merge0 lca mode b1 b2 = do --- c3 <- unionWithM (merge'' lca mode) (_children b1) (_children b2) --- e3 <- unionWithM g (_edits b1) (_edits b2) --- pure $ branch0 (_terms b1 <> _terms b2) --- (_types b1 <> _types b2) --- c3 --- e3 --- where --- g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch) --- g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1) --- g (_, m1) (_, m2) = do --- e1 <- m1 --- e2 <- m2 --- let e3 = e1 <> e2 --- pure (H.accumulate' e3, pure e3) - --- pattern Hash h = Causal.RawHash h - --- toList0 :: Branch0 m -> [(Path, Branch0 m)] --- toList0 = go Path.empty where --- go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) -> --- go (Path.snoc p seg) (head cb) )) - --- printDebugPaths :: Branch m -> String --- printDebugPaths = unlines . map show . Set.toList . debugPaths - --- debugPaths :: Branch m -> Set (Path, Hash) --- debugPaths = go Path.empty where --- go p b = Set.insert (p, headHash b) . Set.unions $ --- [ go (Path.snoc p seg) b | (seg, b) <- Map.toList $ _children (head b) ] - --- data Target = TargetType | TargetTerm | TargetBranch --- deriving (Eq, Ord, Show) - --- instance Eq (Branch0 m) where --- a == b = view terms a == view terms b --- && view types a == view types b --- && view children a == view children b --- && (fmap fst . view edits) a == (fmap fst . view edits) b - --- data ForkFailure = SrcNotFound | DestExists - --- -- consider delegating to Names.numHashChars when ready to implement? --- -- are those enough? --- -- could move this to a read-only field in Branch0 --- -- could move a Names0 to a read-only field in Branch0 until it gets too big --- numHashChars :: Branch m -> Int --- numHashChars _b = 3 - --- -- This type is a little ugly, so we wrap it up with a nice type alias for --- -- use outside this module. --- type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m) - --- boundedCache :: MonadIO m => Word -> m (Cache m2) --- boundedCache = Cache.semispaceCache - --- -- Can use `Cache.nullCache` to disable caching if needed --- cachedRead :: forall m . MonadIO m --- => Cache m --- -> Causal.Deserialize m Raw Raw --- -> (EditHash -> m Patch) --- -> Hash --- -> m (Branch m) --- cachedRead cache deserializeRaw deserializeEdits h = --- Branch <$> Causal.cachedRead cache d h --- where --- fromRaw :: Raw -> m (Branch0 m) --- fromRaw Raw {..} = do --- children <- traverse go _childrenR --- edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash --- pure $ branch0 _termsR _typesR children edits --- go = cachedRead cache deserializeRaw deserializeEdits --- d :: Causal.Deserialize m Raw (Branch0 m) --- d h = deserializeRaw h >>= \case --- RawOne raw -> RawOne <$> fromRaw raw --- RawCons raw h -> flip RawCons h <$> fromRaw raw --- RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw - --- sync --- :: Monad m --- => (Hash -> m Bool) --- -> Causal.Serialize m Raw Raw --- -> (EditHash -> m Patch -> m ()) --- -> Branch m --- -> m () --- sync exists serializeRaw serializeEdits b = do --- _written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty --- -- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files." --- pure () - --- -- serialize a `Branch m` indexed by the hash of its corresponding Raw --- sync' --- :: forall m --- . Monad m --- => (Hash -> m Bool) --- -> Causal.Serialize m Raw Raw --- -> (EditHash -> m Patch -> m ()) --- -> Branch m --- -> StateT (Set Hash) m () --- sync' exists serializeRaw serializeEdits b = Causal.sync exists --- serialize0 --- (view history b) --- where --- serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m) --- serialize0 h b0 = case b0 of --- RawOne b0 -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawOne (toRaw b0) --- RawCons b0 ht -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawCons (toRaw b0) ht --- RawMerge b0 hs -> do --- writeB0 b0 --- lift $ serializeRaw h $ RawMerge (toRaw b0) hs --- where --- writeB0 :: Branch0 m -> StateT (Set Hash) m () --- writeB0 b0 = do --- for_ (view children b0) $ \c -> do --- queued <- State.get --- when (Set.notMember (headHash c) queued) $ --- sync' exists serializeRaw serializeEdits c --- for_ (view edits b0) (lift . uncurry serializeEdits) - --- -- this has to serialize the branch0 and its descendants in the tree, --- -- and then serialize the rest of the history of the branch as well - --- toRaw :: Branch0 m -> Raw --- toRaw Branch0 {..} = --- Raw _terms _types (headHash <$> _children) (fst <$> _edits) - --- toCausalRaw :: Branch m -> Causal.Raw Raw Raw --- toCausalRaw = \case --- Branch (Causal.One _h e) -> RawOne (toRaw e) --- Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht --- Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls) - --- -- copy a path to another path --- fork --- :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- fork src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> case setIfNotExists dest src' root of --- Nothing -> Left DestExists --- Just root' -> Right root' - --- -- Move the node at src to dest. --- -- It's okay if `dest` is inside `src`, just create empty levels. --- -- Try not to `step` more than once at each node. --- move :: Applicative m --- => Path --- -> Path --- -> Branch m --- -> Either ForkFailure (Branch m) --- move src dest root = case getAt src root of --- Nothing -> Left SrcNotFound --- Just src' -> --- -- make sure dest doesn't already exist --- case getAt dest root of --- Just _destExists -> Left DestExists --- Nothing -> --- -- find and update common ancestor of `src` and `dest`: --- Right $ modifyAt ancestor go root --- where --- (ancestor, relSrc, relDest) = Path.relativeToAncestor src dest --- go = deleteAt relSrc . setAt relDest src' - --- setIfNotExists --- :: Applicative m => Path -> Branch m -> Branch m -> Maybe (Branch m) --- setIfNotExists dest b root = case getAt dest root of --- Just _destExists -> Nothing --- Nothing -> Just $ setAt dest b root - --- setAt :: Applicative m => Path -> Branch m -> Branch m -> Branch m --- setAt path b = modifyAt path (const b) - --- deleteAt :: Applicative m => Path -> Branch m -> Branch m --- deleteAt path = setAt path empty - --- -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` --- getAt :: Path --- -> Branch m --- -> Maybe (Branch m) --- getAt path root = case Path.uncons path of --- Nothing -> if isEmpty root then Nothing else Just root --- Just (seg, path) -> case Map.lookup seg (_children $ head root) of --- Just b -> getAt path b --- Nothing -> Nothing - --- getAt' :: Path -> Branch m -> Branch m --- getAt' p b = fromMaybe empty $ getAt p b - --- getAt0 :: Path -> Branch0 m -> Branch0 m --- getAt0 p b = case Path.uncons p of --- Nothing -> b --- Just (seg, path) -> case Map.lookup seg (_children b) of --- Just c -> getAt0 path (head c) --- Nothing -> empty0 - --- empty :: Branch m --- empty = Branch $ Causal.one empty0 - --- one :: Branch0 m -> Branch m --- one = Branch . Causal.one - --- empty0 :: Branch0 m --- empty0 = --- Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty - --- isEmpty0 :: Branch0 m -> Bool --- isEmpty0 = (== empty0) - --- isEmpty :: Branch m -> Bool --- isEmpty = (== empty) - --- step :: Applicative m => (Branch0 m -> Branch0 m) -> Branch m -> Branch m --- step f = \case --- Branch (Causal.One _h e) | e == empty0 -> Branch (Causal.one (f empty0)) --- b -> over history (Causal.stepDistinct f) b - --- stepM :: (Monad m, Monad n) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepM f = \case --- Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 --- b -> mapMOf history (Causal.stepDistinctM f) b - --- cons :: Applicative m => Branch0 m -> Branch m -> Branch m --- cons = step . const - --- isOne :: Branch m -> Bool --- isOne (Branch Causal.One{}) = True --- isOne _ = False - --- uncons :: Applicative m => Branch m -> m (Maybe (Branch0 m, Branch m)) --- uncons (Branch b) = go <$> Causal.uncons b where --- go = over (_Just . _2) Branch - --- -- Modify the branch0 at the head of at `path` with `f`, --- -- after creating it if necessary. Preserves history. --- stepAt :: forall m. Applicative m --- => Path --- -> (Branch0 m -> Branch0 m) --- -> Branch m -> Branch m --- stepAt p f = modifyAt p g where --- g :: Branch m -> Branch m --- g (Branch b) = Branch . Causal.consDistinct (f (Causal.head b)) $ b - --- stepManyAt :: (Monad m, Foldable f) --- => f (Path, Branch0 m -> Branch0 m) -> Branch m -> Branch m --- stepManyAt actions = step (stepManyAt0 actions) - --- -- Modify the branch0 at the head of at `path` with `f`, --- -- after creating it if necessary. Preserves history. --- stepAtM :: forall n m. (Functor n, Applicative m) --- => Path -> (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepAtM p f = modifyAtM p g where --- g :: Branch m -> n (Branch m) --- g (Branch b) = do --- b0' <- f (Causal.head b) --- pure $ Branch . Causal.consDistinct b0' $ b - --- stepManyAtM :: (Monad m, Monad n, Foldable f) --- => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) --- stepManyAtM actions = stepM (stepManyAt0M actions) - --- -- starting at the leaves, apply `f` to every level of the branch. --- stepEverywhere --- :: Applicative m => (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m) --- stepEverywhere f Branch0 {..} = f (branch0 _terms _types children _edits) --- where children = fmap (step $ stepEverywhere f) _children - --- -- Creates a function to fix up the children field._1 --- -- If the action emptied a child, then remove the mapping, --- -- otherwise update it. --- -- Todo: Fix this in hashing & serialization instead of here? --- getChildBranch :: NameSegment -> Branch0 m -> Branch m --- getChildBranch seg b = fromMaybe empty $ Map.lookup seg (_children b) - --- setChildBranch :: NameSegment -> Branch m -> Branch0 m -> Branch0 m --- setChildBranch seg b = over children (updateChildren seg b) - --- getPatch :: Applicative m => NameSegment -> Branch0 m -> m Patch --- getPatch seg b = case Map.lookup seg (_edits b) of --- Nothing -> pure Patch.empty --- Just (_, p) -> p - --- getMaybePatch :: Applicative m => NameSegment -> Branch0 m -> m (Maybe Patch) --- getMaybePatch seg b = case Map.lookup seg (_edits b) of --- Nothing -> pure Nothing --- Just (_, p) -> Just <$> p - --- modifyPatches --- :: Monad m => NameSegment -> (Patch -> Patch) -> Branch0 m -> m (Branch0 m) --- modifyPatches seg f = mapMOf edits update --- where --- update m = do --- p' <- case Map.lookup seg m of --- Nothing -> pure $ f Patch.empty --- Just (_, p) -> f <$> p --- let h = H.accumulate' p' --- pure $ Map.insert seg (h, pure p') m - --- replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m --- replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p)) - --- deletePatch :: NameSegment -> Branch0 m -> Branch0 m --- deletePatch n = over edits (Map.delete n) - --- updateChildren ::NameSegment --- -> Branch m --- -> Map NameSegment (Branch m) --- -> Map NameSegment (Branch m) --- updateChildren seg updatedChild = --- if isEmpty updatedChild --- then Map.delete seg --- else Map.insert seg updatedChild - --- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- Because it's a `Branch`, it overwrites the history at `path`. --- modifyAt :: Applicative m --- => Path -> (Branch m -> Branch m) -> Branch m -> Branch m --- modifyAt path f = runIdentity . modifyAtM path (pure . f) - --- -- Modify the Branch at `path` with `f`, after creating it if necessary. --- -- Because it's a `Branch`, it overwrites the history at `path`. --- modifyAtM --- :: forall n m --- . Functor n --- => Applicative m -- because `Causal.cons` uses `pure` --- => Path --- -> (Branch m -> n (Branch m)) --- -> Branch m --- -> n (Branch m) --- modifyAtM path f b = case Path.uncons path of --- Nothing -> f b --- Just (seg, path) -> do -- Functor --- let child = getChildBranch seg (head b) --- child' <- modifyAtM path f child --- -- step the branch by updating its children according to fixup --- pure $ step (setChildBranch seg child') b - --- -- stepManyAt0 consolidates several changes into a single step --- stepManyAt0 :: forall f m . (Monad m, Foldable f) --- => f (Path, Branch0 m -> Branch0 m) --- -> Branch0 m -> Branch0 m --- stepManyAt0 actions = --- runIdentity . stepManyAt0M [ (p, pure . f) | (p,f) <- toList actions ] - --- stepManyAt0M :: forall m n f . (Monad m, Monad n, Foldable f) --- => f (Path, Branch0 m -> n (Branch0 m)) --- -> Branch0 m -> n (Branch0 m) --- stepManyAt0M actions b = go (toList actions) b where --- go :: [(Path, Branch0 m -> n (Branch0 m))] -> Branch0 m -> n (Branch0 m) --- go actions b = let --- -- combines the functions that apply to this level of the tree --- currentAction b = foldM (\b f -> f b) b [ f | (Path.Empty, f) <- actions ] - --- -- groups the actions based on the child they apply to --- childActions :: Map NameSegment [(Path, Branch0 m -> n (Branch0 m))] --- childActions = --- List.multimap [ (seg, (rest,f)) | (seg :< rest, f) <- actions ] - --- -- alters the children of `b` based on the `childActions` map --- stepChildren :: Map NameSegment (Branch m) -> n (Map NameSegment (Branch m)) --- stepChildren children0 = foldM g children0 $ Map.toList childActions --- where --- g children (seg, actions) = do --- -- Recursively applies the relevant actions to the child branch --- -- The `findWithDefault` is important - it allows the stepManyAt --- -- to create new children at paths that don't previously exist. --- child <- stepM (go actions) (Map.findWithDefault empty seg children0) --- pure $ updateChildren seg child children --- in do --- c2 <- stepChildren (view children b) --- currentAction (set children c2 b) - --- instance Hashable (Branch0 m) where --- tokens b = --- [ H.accumulateToken (_terms b) --- , H.accumulateToken (_types b) --- , H.accumulateToken (headHash <$> _children b) --- , H.accumulateToken (fst <$> _edits b) --- ] - --- -- getLocalBranch :: Hash -> IO Branch --- -- getGithubBranch :: RemotePath -> IO Branch --- -- getLocalEdit :: GUID -> IO Patch - --- -- todo: consider inlining these into Actions2 --- addTermName --- :: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- addTermName r new md = --- over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- addTypeName --- :: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m --- addTypeName r new md = --- over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new)) - --- -- addTermNameAt :: Path.Split -> Referent -> Branch0 m -> Branch0 m --- -- addTypeNameAt :: Path.Split -> Reference -> Branch0 m -> Branch0 m - --- deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m --- deleteTermName r n b | Star3.memberD1 (r,n) (view terms b) --- = over terms (Star3.deletePrimaryD1 (r,n)) b --- deleteTermName _ _ b = b - --- deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m --- deleteTypeName r n b | Star3.memberD1 (r,n) (view types b) --- = over types (Star3.deletePrimaryD1 (r,n)) b --- deleteTypeName _ _ b = b - namesDiff :: Branch m -> Branch m -> Names.Diff namesDiff b1 b2 = Names.diff0 (toNames0 (head b1)) (toNames0 (head b2)) - --- lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) --- lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b - --- diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff --- diff0 old new = do --- newEdits <- sequenceA $ snd <$> _edits new --- oldEdits <- sequenceA $ snd <$> _edits old --- let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty) --- (Map.mapMissing $ \_ p -> Patch.diff mempty p) --- (Map.zipWithMatched (const Patch.diff)) --- newEdits --- oldEdits --- pure $ BranchDiff --- { addedTerms = Star3.difference (_terms new) (_terms old) --- , removedTerms = Star3.difference (_terms old) (_terms new) --- , addedTypes = Star3.difference (_types new) (_types old) --- , removedTypes = Star3.difference (_types old) (_types new) --- , changedPatches = diffEdits --- } - --- transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n --- transform f b = case _history b of --- causal -> Branch . Causal.transform f $ transformB0s f causal --- where --- transformB0 :: Functor m => (forall a . m a -> n a) -> Branch0 m -> Branch0 n --- transformB0 f b = --- b { _children = transform f <$> _children b --- , _edits = second f <$> _edits b --- } - --- transformB0s :: Functor m => (forall a . m a -> n a) --- -> Causal m Raw (Branch0 m) --- -> Causal m Raw (Branch0 n) --- transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) - --- data BranchAttentions = BranchAttentions --- { -- Patches that were edited on the right but entirely removed on the left. --- removedPatchEdited :: [Name] --- -- Patches that were edited on the left but entirely removed on the right. --- , editedPatchRemoved :: [Name] --- } - --- instance Semigroup BranchAttentions where --- BranchAttentions edited1 removed1 <> BranchAttentions edited2 removed2 --- = BranchAttentions (edited1 <> edited2) (removed1 <> removed2) - --- instance Monoid BranchAttentions where --- mempty = BranchAttentions [] [] --- mappend = (<>) - --- data RefCollisions = --- RefCollisions { termCollisions :: Relation Name Name --- , typeCollisions :: Relation Name Name --- } deriving (Eq, Show) - --- instance Semigroup RefCollisions where --- (<>) = mappend --- instance Monoid RefCollisions where --- mempty = RefCollisions mempty mempty --- mappend r1 r2 = RefCollisions (termCollisions r1 <> termCollisions r2) --- (typeCollisions r1 <> typeCollisions r2) diff --git a/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs index 0e47934d5c..6a5769e8e3 100644 --- a/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs +++ b/parser-typechecker/src/Unison/Codebase/BuiltinAnnotation.hs @@ -10,4 +10,4 @@ class BuiltinAnnotation a where builtinAnnotation :: a instance BuiltinAnnotation Ann where - builtinAnnotation = Ann.Intrinsic \ No newline at end of file + builtinAnnotation = Ann.Intrinsic diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs index c9d51fc77e..09b3eeb9ed 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs @@ -7,4 +7,4 @@ import U.Codebase.Sqlite.DbId (SchemaVersion) data GitSqliteCodebaseError = GitCouldntParseRootBranchHash ReadRepo String | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion - deriving Show \ No newline at end of file + deriving Show diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 999f37a3a7..01b6600c6b 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -96,4 +96,4 @@ data GitError = GitProtocolError GitProtocolError | GitCodebaseError (GitCodebaseError Branch.Hash) | GitSqliteCodebaseError GitSqliteCodebaseError - deriving Show \ No newline at end of file + deriving Show diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 1b75cf7bbb..5817d0ddd4 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -678,9 +678,6 @@ notifyUser dir o = case o of TodoOutput names todo -> pure (todoOutput names todo) GitError input e -> pure $ case e of - -- CouldntOpenCodebase repo localPath -> P.wrap $ "I couldn't open the repository at" - -- <> prettyReadRepo repo <> "in the cache directory at" - -- <> P.backticked' (P.string localPath) "." GitSqliteCodebaseError e -> case e of UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap $ "I don't know how to interpret schema version " <> P.shown v @@ -750,11 +747,6 @@ notifyUser dir o = case o of "", P.wrap "Try again with a few more hash characters to disambiguate." ] - -- SomeOtherError msg -> P.callout "‼" . P.lines $ [ - -- P.wrap "I ran into an error:", "", - -- P.indentN 2 (P.string msg), "", - -- P.wrap $ "Check the logging messages above for more info." - -- ] ListEdits patch ppe -> do let types = Patch._typeEdits patch diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs index ecf2d1af5e..0dd8db24f3 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs @@ -1,35 +1,14 @@ -{-# Language OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -module Unison.PrettyPrintEnv.Util where +module Unison.PrettyPrintEnv.Util (declarationPPE) where -import Unison.Prelude - -import qualified Data.Map as Map import qualified Data.Set as Set -import Unison.HashQualified (HashQualified) -import qualified Unison.HashQualified as HQ -import Unison.Name (Name) -import qualified Unison.Name as Name -import Unison.PrettyPrintEnv +import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (suffixifiedPPE, unsuffixifiedPPE)) import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import Unison.Referent (Referent) import qualified Unison.Referent as Referent --- fromNames :: Int -> Names -> PrettyPrintEnv --- fromNames len names = PrettyPrintEnv terms' types' where --- terms' r = shortestName . Set.map HQ'.toHQ $ Names.termName len r names --- types' r = shortestName . Set.map HQ'.toHQ $ Names.typeName len r names --- shortestName ns = safeHead $ HQ.sortByLength (toList ns) - --- fromSuffixNames :: Int -> Names -> PrettyPrintEnv --- fromSuffixNames len names = fromNames len (Names.suffixify names) - --- fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl --- fromNamesDecl len names = --- PrettyPrintEnvDecl (fromNames len names) (fromSuffixNames len names) - -- declarationPPE uses the full name for references that are -- part the same cycle as the input reference, used to ensures -- recursive definitions are printed properly, for instance: @@ -38,69 +17,15 @@ import qualified Unison.Referent as Referent -- and not -- foo.bar x = bar x declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv -declarationPPE ppe rd = PrettyPrintEnv tm ty where - comp = Reference.members (Reference.componentFor rd) - tm r0@(Referent.Ref r) = if Set.member r comp - then terms (unsuffixifiedPPE ppe) r0 - else terms (suffixifiedPPE ppe) r0 - tm r = terms (suffixifiedPPE ppe) r - ty r = if Set.member r comp then types (unsuffixifiedPPE ppe) r - else types (suffixifiedPPE ppe) r - --- Left-biased union of environments -unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv -unionLeft e1 e2 = PrettyPrintEnv - (\r -> terms e1 r <|> terms e2 r) - (\r -> types e1 r <|> types e2 r) - -assignTermName - :: Referent -> HashQualified Name -> PrettyPrintEnv -> PrettyPrintEnv -assignTermName r name = (fromTermNames [(r, name)] `unionLeft`) - -fromTypeNames :: [(Reference, HashQualified Name)] -> PrettyPrintEnv -fromTypeNames types = - let m = Map.fromList types in PrettyPrintEnv (const Nothing) (`Map.lookup` m) - -fromTermNames :: [(Referent, HashQualified Name)] -> PrettyPrintEnv -fromTermNames tms = - let m = Map.fromList tms in PrettyPrintEnv (`Map.lookup` m) (const Nothing) - --- todo: these need to be a dynamic length, but we need additional info -todoHashLength :: Int -todoHashLength = 10 - --- termName :: PrettyPrintEnv -> Referent -> HashQualified Name --- termName env r = --- fromMaybe (HQ.take todoHashLength $ HQ.fromReferent r) (terms env r) - --- typeName :: PrettyPrintEnv -> Reference -> HashQualified Name --- typeName env r = --- fromMaybe (HQ.take todoHashLength $ HQ.fromReference r) (types env r) - -patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name -patternName env r cid = - case patterns env r cid of - Just name -> name - Nothing -> HQ.take todoHashLength $ HQ.fromPattern r cid - --- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' --- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. - --- Note that a Suffix can include dots. -type Suffix = Text --- Each member of a Prefix list is dot-free. -type Prefix = [Text] --- Keys are FQNs, values are shorter names which are equivalent, thanks to use --- statements that are in scope. -type Imports = Map Name Suffix - --- Give the shortened version of an FQN, if there's been a `use` statement for that FQN. -elideFQN :: Imports -> HQ.HashQualified Name -> HQ.HashQualified Name -elideFQN imports hq = - let hash = HQ.toHash hq - name' = do name <- HQ.toName hq - let hit = fmap Name.unsafeFromText (Map.lookup name imports) - -- Cut out the "const id $" to get tracing of FQN elision attempts. - let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) - t (pure $ fromMaybe name hit) - in HQ.fromNameHash name' hash +declarationPPE ppe rd = PrettyPrintEnv tm ty + where + comp = Reference.members (Reference.componentFor rd) + tm r0@(Referent.Ref r) = + if Set.member r comp + then terms (unsuffixifiedPPE ppe) r0 + else terms (suffixifiedPPE ppe) r0 + tm r = terms (suffixifiedPPE ppe) r + ty r = + if Set.member r comp + then types (unsuffixifiedPPE ppe) r + else types (suffixifiedPPE ppe) r diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index 7af77d77e1..a1c0a1a61d 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -49,6 +49,8 @@ import qualified Unison.Util.SyntaxText as S type Nat = Word64 +type SSyntaxText = S.SyntaxText' Reference + data Doc = Word Text | Code Doc @@ -154,7 +156,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case source :: Term v () -> m SyntaxText source tm = (pure . formatPretty . TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped)) tm - goSignatures :: [Referent] -> m [P.Pretty (S.SyntaxText' Reference)] + goSignatures :: [Referent] -> m [P.Pretty SSyntaxText] goSignatures rs = runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case Nothing -> pure ["🆘 codebase is missing type signature for these definitions"] Just types -> pure . fmap P.group $ @@ -185,9 +187,9 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case -- Link (Either Link.Type Doc2.Term) DD.Doc2SpecialFormLink e -> let ppe = PPE.suffixifiedPPE pped - tm :: Referent -> P.Pretty (S.SyntaxText' Reference) + tm :: Referent -> P.Pretty SSyntaxText tm r = (NP.styleHashQualified'' (NP.fmt (S.Referent r)) . PPE.termName ppe) r - ty :: Reference -> P.Pretty (S.SyntaxText' Reference) + ty :: Reference -> P.Pretty SSyntaxText ty r = (NP.styleHashQualified'' (NP.fmt (S.Reference r)) . PPE.typeName ppe) r in Link <$> case e of DD.EitherLeft' (Term.TypeLink' r) -> (pure . formatPretty . ty) r diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 002d0f24aa..72bda10f9d 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -6,47 +6,47 @@ module Unison.TermPrinter where import Unison.Prelude -import Control.Monad.State (evalState) -import qualified Control.Monad.State as State -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Text ( unpack ) -import qualified Data.Text as Text -import qualified Text.Show.Unicode as U -import Data.Vector ( ) -import Unison.ABT ( pattern AbsN', reannotateUp, annotation ) -import qualified Unison.ABT as ABT -import qualified Unison.Blank as Blank -import qualified Unison.HashQualified as HQ -import Unison.Lexer ( symbolyId, showEscapeChar ) -import Unison.Name ( Name ) -import qualified Unison.Name as Name -import qualified Unison.NameSegment as NameSegment -import Unison.NamePrinter ( styleHashQualified'' ) -import qualified Unison.Pattern as Pattern -import Unison.Pattern ( Pattern ) -import Unison.Reference ( Reference ) -import qualified Unison.Reference as Reference -import qualified Unison.Referent as Referent -import Unison.Referent ( Referent ) -import qualified Unison.Util.SyntaxText as S -import Unison.Term -import Unison.Type ( Type ) -import qualified Unison.Type as Type -import qualified Unison.TypePrinter as TypePrinter -import Unison.Var ( Var ) -import qualified Unison.Var as Var -import qualified Unison.Util.Bytes as Bytes -import Unison.Util.Monoid ( intercalateMap ) -import qualified Unison.Util.Pretty as PP -import Unison.Util.Pretty ( Pretty, ColorText, Width ) +import Control.Monad.State (evalState) +import qualified Control.Monad.State as State +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (unpack) +import qualified Data.Text as Text +import Data.Vector () +import qualified Text.Show.Unicode as U +import Unison.ABT (annotation, reannotateUp, pattern AbsN') +import qualified Unison.ABT as ABT +import qualified Unison.Blank as Blank +import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm') +import qualified Unison.Builtin.Decls as DD +import qualified Unison.ConstructorType as CT +import qualified Unison.HashQualified as HQ +import Unison.Lexer (showEscapeChar, symbolyId) +import Unison.Name (Name) +import qualified Unison.Name as Name +import Unison.NamePrinter (styleHashQualified'') +import qualified Unison.NameSegment as NameSegment +import Unison.Pattern (Pattern) +import qualified Unison.Pattern as Pattern import Unison.PrettyPrintEnv (PrettyPrintEnv) import qualified Unison.PrettyPrintEnv as PrettyPrintEnv import Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) -import qualified Unison.Builtin.Decls as DD -import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm') -import qualified Unison.ConstructorType as CT +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import Unison.Referent (Referent) +import qualified Unison.Referent as Referent +import Unison.Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.TypePrinter as TypePrinter +import qualified Unison.Util.Bytes as Bytes +import Unison.Util.Monoid (intercalateMap) +import Unison.Util.Pretty (ColorText, Pretty, Width) +import qualified Unison.Util.Pretty as PP +import qualified Unison.Util.SyntaxText as S +import Unison.Var (Var) +import qualified Unison.Var as Var type SyntaxText = S.SyntaxText' Reference @@ -212,14 +212,14 @@ pretty0 Just c -> "?\\" ++ [c] Nothing -> '?': [c] Blank' id -> fmt S.Blank $ l "_" <> l (fromMaybe "" (Blank.nameb id)) - Constructor' ref cid -> + Constructor' ref cid -> styleHashQualified'' (fmt $ S.Referent conRef) name - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Data - Request' ref cid -> + Request' ref cid -> styleHashQualified'' (fmt $ S.Referent conRef) name - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Effect Handle' h body -> paren (p >= 2) $ @@ -324,7 +324,7 @@ pretty0 if isDocLiteral term then prettyDoc n im term else pretty0 n (a {docContext = NoDoc}) term - (TupleTerm' [x], _) -> + (TupleTerm' [x], _) -> let conRef = DD.pairCtorRef name = elideFQN im $ PrettyPrintEnv.termName n conRef @@ -333,10 +333,10 @@ pretty0 paren (p >= 10) $ pair `PP.hang` PP.spaced [pretty0 n (ac 10 Normal im doc) x, fmt (S.Referent DD.unitCtorRef) "()" ] - (TupleTerm' xs, _) -> + (TupleTerm' xs, _) -> let tupleLink p = fmt (S.Reference DD.unitRef) p in PP.group (tupleLink "(" <> commaList xs <> tupleLink ")") - + (Bytes' bs, _) -> fmt S.BytesLiteral "0xs" <> (PP.shown $ Bytes.fromWord8s (map fromIntegral bs)) BinaryAppsPred' apps lastArg -> paren (p >= 3) $ @@ -449,7 +449,7 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of in (PP.parenthesizeCommas pats_printed, tail_vs) Pattern.Constructor _ ref cid [] -> (styleHashQualified'' (fmt $ S.Referent conRef) name, vs) - where + where name = elideFQN im $ PrettyPrintEnv.termName n conRef conRef = Referent.Con ref cid CT.Data Pattern.Constructor _ ref cid pats -> @@ -474,7 +474,7 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of conRef = Referent.Con ref cid CT.Effect in ( PP.group ( fmt S.DelimiterChar "{" <> - (PP.sep " " . PP.nonEmpty $ + (PP.sep " " . PP.nonEmpty $ [ styleHashQualified'' (fmt (S.Referent conRef)) $ name , pats_printed , fmt S.ControlKeyword "->" diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index 231a527675..9925918434 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -119,13 +119,3 @@ environmentFor names dataDecls0 effectDecls0 = do if null overlaps && null unknownTypeRefs then pure $ Env dataDecls' effectDecls' names' else Left (unknownTypeRefs ++ overlaps) - --- allVars :: Ord v => UnisonFile v a -> Set v --- allVars (UnisonFile ds es ts ws) = Set.unions --- [ Map.keysSet ds --- , foldMap (DD.allVars . snd) ds --- , Map.keysSet es --- , foldMap (DD.allVars . toDataDecl . snd) es --- , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- ts ] --- , Set.unions [ Set.insert v (Term.allVars t) | (v, t) <- join . Map.elems $ ws ] --- ] diff --git a/parser-typechecker/tests/Unison/Test/Ucm.hs b/parser-typechecker/tests/Unison/Test/Ucm.hs index 8117ff31e9..a9a84752fa 100644 --- a/parser-typechecker/tests/Unison/Test/Ucm.hs +++ b/parser-typechecker/tests/Unison/Test/Ucm.hs @@ -6,7 +6,6 @@ module Unison.Test.Ucm ( initCodebase, deleteCodebase, runTranscript, - upgradeCodebase, lowLevel, CodebaseFormat (..), Transcript, @@ -60,9 +59,6 @@ initCodebase fmt = do deleteCodebase :: Codebase -> IO () deleteCodebase (Codebase path _) = removeDirectoryRecursive path -upgradeCodebase :: Codebase -> IO Codebase -upgradeCodebase = undefined - runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do -- this configFile ought to be optional diff --git a/unison-core/src/Unison/DataDeclaration/ConstructorId.hs b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs index d04f59f280..0de60aed08 100644 --- a/unison-core/src/Unison/DataDeclaration/ConstructorId.hs +++ b/unison-core/src/Unison/DataDeclaration/ConstructorId.hs @@ -8,4 +8,4 @@ module Unison.DataDeclaration.ConstructorId (ConstructorId) where -type ConstructorId = Int \ No newline at end of file +type ConstructorId = Int diff --git a/unison-core/src/Unison/Type/Names.hs b/unison-core/src/Unison/Type/Names.hs index f8a9ad69ff..2a3936d443 100644 --- a/unison-core/src/Unison/Type/Names.hs +++ b/unison-core/src/Unison/Type/Names.hs @@ -30,4 +30,4 @@ bindNames keepFree ns0 t = let rs = [(v, a, Names.lookupHQType (Name.convert $ Name.fromVar v) ns) | (v,a) <- fvs ] ok (v, a, rs) = if Set.size rs == 1 then pure (v, Set.findMin rs) else Left (pure (Names.TypeResolutionFailure v a rs)) - in List.validate ok rs <&> \es -> bindExternal es t \ No newline at end of file + in List.validate ok rs <&> \es -> bindExternal es t diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index 2ffb55b4a7..d493cfef2b 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -6,16 +6,13 @@ module Unison.Var where import Unison.Prelude -import Data.Char (toLower, isLower) +import Data.Char (isLower, toLower) import Data.Text (pack) import qualified Data.Text as Text import qualified Unison.ABT as ABT import qualified Unison.NameSegment as Name -import Unison.WatchKind - import Unison.Util.Monoid (intercalateMap) --- import Unison.Reference (Reference) --- import qualified Unison.Reference as R +import Unison.WatchKind (WatchKind, pattern TestWatch) -- | A class for variables. Variables may have auxiliary information which -- may not form part of their identity according to `Eq` / `Ord`. Laws: diff --git a/unison-core/src/Unison/Var/RefNamed.hs b/unison-core/src/Unison/Var/RefNamed.hs index f963f6e9d0..446359b20a 100644 --- a/unison-core/src/Unison/Var/RefNamed.hs +++ b/unison-core/src/Unison/Var/RefNamed.hs @@ -10,4 +10,4 @@ import Unison.Var (Var) import qualified Unison.Var as Var refNamed :: Var v => Reference -> v -refNamed ref = Var.named ("ℍ" <> Reference.toText ref) \ No newline at end of file +refNamed ref = Var.named ("ℍ" <> Reference.toText ref) From 4346f57aceeaa521f8a72eb0460807f3ed3296b7 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 20:46:14 -0400 Subject: [PATCH 028/148] restore `-Werror` --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 1b48f4ad13..1d657ef12c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -50,7 +50,7 @@ extra-deps: ghc-options: # All packages - "$locals": -Wall -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors + "$locals": -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors # See https://github.com/haskell/haskell-language-server/issues/208 "$everything": -haddock From a2e5895d95eeed80bed0dbd0bec5c61912a2c7fa Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 30 Aug 2021 20:50:14 -0400 Subject: [PATCH 029/148] not sure where this came from --- unison-src/transcripts/fix2344.output.md | 31 ++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 unison-src/transcripts/fix2344.output.md diff --git a/unison-src/transcripts/fix2344.output.md b/unison-src/transcripts/fix2344.output.md new file mode 100644 index 0000000000..b58713fbcb --- /dev/null +++ b/unison-src/transcripts/fix2344.output.md @@ -0,0 +1,31 @@ + +Checks a corner case with type checking involving destructuring binds. + +The binds were causing some sequences of lets to be unnecessarily +recursive. + +```unison +unique ability Nate where + nate: (Boolean, Nat) + antiNate: () + + +sneezy: (Nat -> {d} a) -> '{Nate,d} a +sneezy dee _ = + (_,_) = nate + antiNate + dee 1 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique ability Nate + sneezy : (Nat ->{d} a) -> '{d, Nate} a + +``` From 3570c20dacc37ccb6ee69b10c286ddb348f1a50c Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Mon, 30 Aug 2021 21:32:12 -0400 Subject: [PATCH 030/148] temporary downgrade to stackage 18.6 Just until there is a haskell-language-server binary release that is compatible with it. See https://github.com/haskell/vscode-haskell#supported-ghc-versions /cc @hojberg @rlmark @pchiusano --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 1d657ef12c..eabcc02872 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ packages: - codebase2/util-term #compiler-check: match-exact -resolver: lts-18.7 +resolver: lts-18.6 extra-deps: - github: unisonweb/configurator From 9d7278df72da5d9f4e9d65667c2dd6c3589ac5f2 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 31 Aug 2021 11:17:11 -0400 Subject: [PATCH 031/148] Fix stale transcript output --- unison-src/transcripts/fix2355.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/fix2355.output.md b/unison-src/transcripts/fix2355.output.md index 498f0fd949..61e8b147f4 100644 --- a/unison-src/transcripts/fix2355.output.md +++ b/unison-src/transcripts/fix2355.output.md @@ -30,7 +30,7 @@ example = 'let where `𝕖18` is its overall abilities. - I need a type signature to properly figure this out. + I need a type signature to help figure this out. 10 | go u = 11 | t = A.fork '(go (u + 1)) From e32b2b0057987fe916004af6b3120ed5934cd0cf Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 31 Aug 2021 11:15:35 -0500 Subject: [PATCH 032/148] Improve testing of link/unlink Adds a check for links by type, and a check for unlink --- unison-src/transcripts/link.md | 3 +++ unison-src/transcripts/link.output.md | 14 ++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/unison-src/transcripts/link.md b/unison-src/transcripts/link.md index 46720e385e..d3fde27594 100644 --- a/unison-src/transcripts/link.md +++ b/unison-src/transcripts/link.md @@ -48,6 +48,7 @@ We can look at the links we have: ```ucm .> links coolFunction +.> links coolFunction License ``` We can link the same metadata simultaneously to multiple definitions: @@ -67,4 +68,6 @@ myLibrary.h x = x + 3 .myLibrary> links g .myLibrary> links h .myLibrary> history + +.> unlink coolFunction.doc coolFunction ``` diff --git a/unison-src/transcripts/link.output.md b/unison-src/transcripts/link.output.md index d8401c644b..e507b82102 100644 --- a/unison-src/transcripts/link.output.md +++ b/unison-src/transcripts/link.output.md @@ -108,6 +108,13 @@ We can look at the links we have: Tip: Try using `display 1` to display the first result or `view 1` to view its source. +.> links coolFunction License + + 1. coolFunction.license : License + + Tip: Try using `display 1` to display the first result or + `view 1` to view its source. + ``` We can link the same metadata simultaneously to multiple definitions: @@ -193,4 +200,11 @@ myLibrary.h x = x + 3 □ #7rksc58cce (start of history) +.> unlink coolFunction.doc coolFunction + + Updates: + + 1. coolFunction : Nat -> Nat + - 2. doc : Doc + ``` From 4bed93a203c22fbd5eeff51923911585a8d3a005 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 31 Aug 2021 12:03:37 -0400 Subject: [PATCH 033/148] Add new server endpoint: /namespaces/:fqn Add a new server endpoint for fetching the details of a namespace: `/namespaces/:fqn`, can be used like so `/namespaces/base.List`. This is served by the `NamespaceDetails` API which looks for a readme (any capitalization) in the namespace and renders it. Additionally I cleaned up a few things with regards to naming of the previous `ListNamespace` module to match what it was returning. Down the line the 2 APIs might be merged into a single `Namespaces` API. --- .../src/Unison/Server/Backend.hs | 135 +++++++++++++----- .../src/Unison/Server/CodebaseServer.hs | 56 ++++---- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 6 +- .../Server/Endpoints/NamespaceDetails.hs | 111 ++++++++++++++ .../{ListNamespace.hs => NamespaceListing.hs} | 15 +- parser-typechecker/src/Unison/Server/Types.hs | 13 +- .../unison-parser-typechecker.cabal | 3 +- 7 files changed, 265 insertions(+), 74 deletions(-) create mode 100644 parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs rename parser-typechecker/src/Unison/Server/Endpoints/{ListNamespace.hs => NamespaceListing.hs} (94%) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 226fd53ade..2fc02987b4 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -258,6 +258,50 @@ findShallow codebase path' = do Nothing -> pure [] Just b -> findShallowInBranch codebase b +findShallowReadmeInBranch :: + (Monad m, Var v) => + Codebase m v Ann -> + Branch m -> + Backend m (Maybe (TermEntry v Ann)) +findShallowReadmeInBranch codebase branch = + let find :: [ShallowListEntry v Ann] -> Maybe (TermEntry v Ann) + find entries = + case entries of + [] -> Nothing + e : rest -> + case e of + ShallowTermEntry termEntry@(TermEntry _ segment _ _) -> + if (Text.toUpper . HQ'.toText $ segment) == "README" + then Just termEntry + else find rest + _ -> + find rest + in fmap find (findShallowInBranch codebase branch) + + +findShallowReadmeInBranchAndRender :: + Var v => + Width -> + Rt.Runtime v -> + Codebase IO v Ann -> + Branch IO -> + Backend IO (Maybe Doc.Doc) +findShallowReadmeInBranchAndRender width runtime codebase branch = + let ppe hqLen = PPE.fromNamesDecl hqLen printNames + + printNames = getCurrentPrettyNames (Path.fromList []) branch + + renderReadme ppe (TermEntry r _ _ _) = do + res <- renderDoc ppe width runtime codebase (Referent.toReference r) + pure $ case res of + (_, _, doc) : _ -> Just doc + _ -> Nothing + in do + hqLen <- liftIO $ Codebase.hashLength codebase + readmeTerm <- findShallowReadmeInBranch codebase branch + join <$> traverse (renderReadme (ppe hqLen)) readmeTerm + + termListEntry :: Monad m => Var v @@ -333,7 +377,7 @@ termEntryToNamedTerm termEntryToNamedTerm ppe typeWidth (TermEntry r name mayType tag) = NamedTerm { termName = HQ'.toText name , termHash = Referent.toText r - , termType = formatType ppe (mayDefault typeWidth) <$> mayType + , termType = formatType ppe (mayDefaultWidth typeWidth) <$> mayType , termTag = tag } @@ -610,7 +654,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod parseNames = getCurrentParseNames (fromMaybe Path.empty relativeTo) branch ppe = PPE.fromNamesDecl hqLength printNames - width = mayDefault renderWidth + width = mayDefaultWidth renderWidth isAbsolute (Name.toText -> n) = "." `Text.isPrefixOf` n && n /= "." termFqns :: Map Reference (Set Text) termFqns = Map.mapWithKey f terms @@ -638,34 +682,6 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod _ -> pure [] pure [ r | (r, t) <- rts, Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref) ] - renderDoc :: Reference -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] - renderDoc r = do - let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r) - let hash = Reference.toText r - map (name,hash,) . pure <$> - let tm = Term.ref () r - in Doc.renderDoc @v ppe terms typeOf eval decls tm - where - terms r@(Reference.Builtin _) = pure (Just (Term.ref () r)) - terms (Reference.DerivedId r) = - fmap Term.unannotate <$> lift (Codebase.getTerm codebase r) - - typeOf r = fmap void <$> lift (Codebase.getTypeOfReferent codebase r) - eval (Term.amap (const mempty) -> tm) = do - let ppes = PPE.suffixifiedPPE ppe - let codeLookup = Codebase.toCodeLookup codebase - let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r - r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm - lift $ case r of - Just tmr -> Codebase.putWatch codebase WK.RegularWatch - (Term.hashClosedTerm tm) - (Term.amap (const mempty) tmr) - Nothing -> pure () - pure $ r <&> Term.amap (const mempty) - - decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> lift (Codebase.getTypeDeclaration codebase r) - decls _ = pure Nothing - -- rs0 can be empty or the term fetched, so when viewing a doc term -- you get both its source and its rendered form docResults :: [Reference] -> [Name] -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] @@ -675,7 +691,7 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod -- lookup the type of each, make sure it's a doc docs <- selectDocs (toList rs) -- render all the docs - join <$> traverse renderDoc docs + join <$> traverse (renderDoc ppe width rt codebase) docs mkTermDefinition r tm = do ts <- lift (Codebase.getTypeOfTerm codebase r) @@ -719,6 +735,46 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt cod renderedDisplayTypes renderedMisses +renderDoc :: + forall v. + Var v => + PPE.PrettyPrintEnvDecl -> + Width -> + Rt.Runtime v -> + Codebase IO v Ann -> + Reference -> + Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] +renderDoc ppe width rt codebase r = do + let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r) + let hash = Reference.toText r + map (name,hash,) . pure + <$> let tm = Term.ref () r + in Doc.renderDoc @v ppe terms typeOf eval decls tm + where + terms r@(Reference.Builtin _) = pure (Just (Term.ref () r)) + terms (Reference.DerivedId r) = + fmap Term.unannotate <$> lift (Codebase.getTerm codebase r) + + typeOf r = fmap void <$> lift (Codebase.getTypeOfReferent codebase r) + eval (Term.amap (const mempty) -> tm) = do + let ppes = PPE.suffixifiedPPE ppe + let codeLookup = Codebase.toCodeLookup codebase + let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r + r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm + lift $ case r of + Just tmr -> + Codebase.putWatch + codebase + WK.RegularWatch + (Term.hashClosedTerm tm) + (Term.amap (const mempty) tmr) + Nothing -> pure () + pure $ r <&> Term.amap (const mempty) + + decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> lift (Codebase.getTypeDeclaration codebase r) + decls _ = pure Nothing + + bestNameForTerm :: forall v . Var v => PPE.PrettyPrintEnv -> Width -> Referent -> Text bestNameForTerm ppe width = @@ -737,14 +793,25 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () -resolveBranchHash - :: Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) +resolveBranchHash :: + Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) resolveBranchHash h codebase = case h of - Nothing -> getRootBranch codebase + Nothing -> getRootBranch codebase Just bhash -> do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash mayBranch ?? NoBranchForHash bhash + +resolveRootBranchHash :: + Monad m => Maybe ShortBranchHash -> Codebase m v Ann -> Backend m (Branch m) +resolveRootBranchHash mayRoot codebase = case mayRoot of + Nothing -> + getRootBranch codebase + Just sbh -> do + h <- expandShortBranchHash codebase sbh + resolveBranchHash (Just h) codebase + + definitionsBySuffixes :: forall m v . (MonadIO m) diff --git a/parser-typechecker/src/Unison/Server/CodebaseServer.hs b/parser-typechecker/src/Unison/Server/CodebaseServer.hs index 0ea88e2511..6c4e1f9335 100644 --- a/parser-typechecker/src/Unison/Server/CodebaseServer.hs +++ b/parser-typechecker/src/Unison/Server/CodebaseServer.hs @@ -85,7 +85,8 @@ import Unison.Server.Endpoints.GetDefinitions ( DefinitionsAPI, serveDefinitions, ) -import Unison.Server.Endpoints.ListNamespace (NamespaceAPI, serveNamespace) +import qualified Unison.Server.Endpoints.NamespaceDetails as NamespaceDetails +import qualified Unison.Server.Endpoints.NamespaceListing as NamespaceListing import Unison.Server.Types (mungeString) import Unison.Var (Var) @@ -104,7 +105,12 @@ type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw -type UnisonAPI = NamespaceAPI :<|> DefinitionsAPI :<|> FuzzyFindAPI +type UnisonAPI = + NamespaceListing.NamespaceListingAPI + :<|> NamespaceDetails.NamespaceDetailsAPI + :<|> DefinitionsAPI + :<|> FuzzyFindAPI + type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml @@ -270,30 +276,28 @@ serveIndex path = do serveUI :: Handler () -> FilePath -> Server WebUI serveUI tryAuth path _ = tryAuth *> serveIndex path -server - :: Var v - => Rt.Runtime v - -> Codebase IO v Ann - -> FilePath - -> Strict.ByteString - -> Server AuthedServerAPI +server :: + Var v => + Rt.Runtime v -> + Codebase IO v Ann -> + FilePath -> + Strict.ByteString -> + Server AuthedServerAPI server rt codebase uiPath token = serveDirectoryWebApp (uiPath "static") - :<|> ((\t -> - serveUI (tryAuth t) uiPath - :<|> ( ( (serveNamespace (tryAuth t) codebase) - :<|> (serveDefinitions (tryAuth t) rt codebase) - :<|> (serveFuzzyFind (tryAuth t) codebase) - ) - :<|> serveOpenAPI - :<|> Tagged serveDocs - ) - ) + :<|> ( \token -> + serveUI (tryAuth token) uiPath + :<|> unisonApi token + :<|> serveOpenAPI + :<|> Tagged serveDocs ) - - where - serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS - serveOpenAPI = pure openAPI - plain = ("Content-Type", "text/plain") - tryAuth = handleAuth token - + where + serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS + serveOpenAPI = pure openAPI + plain = ("Content-Type", "text/plain") + tryAuth = handleAuth token + unisonApi t = + NamespaceListing.serve (tryAuth t) codebase + :<|> NamespaceDetails.serve (tryAuth t) rt codebase + :<|> serveDefinitions (tryAuth t) rt codebase + :<|> serveFuzzyFind (tryAuth t) codebase diff --git a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs index ae2381ac63..4f789998a6 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -53,7 +53,7 @@ import Unison.Server.Types NamedTerm, NamedType, addHeaders, - mayDefault, + mayDefaultWidth, ) import Unison.Util.Pretty (Width) import Unison.Var (Var) @@ -162,7 +162,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = ( a , FoundTermResult . FoundTerm - (Backend.bestNameForTerm @v ppe (mayDefault typeWidth) r) + (Backend.bestNameForTerm @v ppe (mayDefaultWidth typeWidth) r) $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) @@ -170,7 +170,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = Backend.FoundTypeRef r -> do te <- Backend.typeListEntry codebase r n let namedType = Backend.typeEntryToNamedType te - let typeName = Backend.bestNameForType @v ppe (mayDefault typeWidth) r + let typeName = Backend.bestNameForType @v ppe (mayDefaultWidth typeWidth) r typeHeader <- Backend.typeDeclHeader codebase ppe r let ft = FoundType typeName typeHeader namedType pure (a, FoundTypeResult ft) diff --git a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs new file mode 100644 index 0000000000..ae60d760b3 --- /dev/null +++ b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Unison.Server.Endpoints.NamespaceDetails where + +import Control.Error (runExceptT) +import Data.Aeson +import Data.OpenApi (ToSchema) +import qualified Data.Text as Text +import Servant (Capture, QueryParam, throwError, (:>)) +import Servant.Docs (DocCapture (..), ToCapture (..), ToSample (..)) +import Servant.OpenApi () +import Servant.Server (Handler) +import Unison.Codebase (Codebase) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Path as Path +import Unison.Codebase.Path.Parse (parsePath') +import qualified Unison.Codebase.Runtime as Rt +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import qualified Unison.Server.Backend as Backend +import Unison.Server.Doc (Doc) +import Unison.Server.Errors (backendError, badNamespace) +import Unison.Server.Types + ( APIGet, + APIHeaders, + NamespaceFQN, + UnisonHash, + UnisonName, + addHeaders, + branchToUnisonHash, + mayDefaultWidth, + ) +import Unison.Util.Pretty (Width) +import Unison.Var (Var) + +type NamespaceDetailsAPI = + "namespaces" :> Capture "namespace" NamespaceFQN + :> QueryParam "rootBranch" ShortBranchHash + :> QueryParam "renderWidth" Width + :> APIGet NamespaceDetails + +instance ToCapture (Capture "namespace" Text) where + toCapture _ = + DocCapture + "namespace" + "The fully qualified name of a namespace. The leading `.` is optional." + +instance ToSample NamespaceDetails where + toSamples _ = + [ ( "When no value is provided for `namespace`, the root namespace `.` is " + <> "listed by default", + NamespaceDetails + "." + "#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5" + Nothing + ) + ] + +data NamespaceDetails = NamespaceDetails + { fqn :: UnisonName, + hash :: UnisonHash, + readme :: Maybe Doc + } + deriving (Generic, Show) + +instance ToJSON NamespaceDetails where + toEncoding = genericToEncoding defaultOptions + +deriving instance ToSchema NamespaceDetails + +serve :: + Var v => + Handler () -> + Rt.Runtime v -> + Codebase IO v Ann -> + NamespaceFQN -> + Maybe ShortBranchHash -> + Maybe Width -> + Handler (APIHeaders NamespaceDetails) +serve tryAuth runtime codebase namespaceName mayRoot mayWidth = + let doBackend a = do + ea <- liftIO $ runExceptT a + errFromEither backendError ea + + errFromEither f = either (throwError . f) pure + + fqnToPath fqn = do + let fqnS = Text.unpack fqn + path' <- errFromEither (`badNamespace` fqnS) $ parsePath' fqnS + pure (Path.fromPath' path') + + width = mayDefaultWidth mayWidth + in do + namespacePath <- fqnToPath namespaceName + + namespaceDetails <- doBackend $ do + root <- Backend.resolveRootBranchHash mayRoot codebase + let namespaceBranch = Branch.getAt' namespacePath root + readme <- Backend.findShallowReadmeInBranchAndRender width runtime codebase namespaceBranch + + pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme + + addHeaders <$> (tryAuth $> namespaceDetails) diff --git a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs similarity index 94% rename from parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs rename to parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs index dcedb00072..560be33f9d 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Unison.Server.Endpoints.ListNamespace where +module Unison.Server.Endpoints.NamespaceListing where import Control.Error (runExceptT) import Data.Aeson @@ -29,12 +29,10 @@ import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Hash as Hash import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -56,13 +54,14 @@ import Unison.Server.Types UnisonHash, UnisonName, addHeaders, + branchToUnisonHash, ) import Unison.Util.Pretty (Width) import Unison.Var (Var) import Control.Error.Util ((??)) -type NamespaceAPI = +type NamespaceListingAPI = "list" :> QueryParam "rootBranch" ShortBranchHash :> QueryParam "relativeTo" NamespaceFQN :> QueryParam "namespace" NamespaceFQN @@ -157,7 +156,7 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name -serveNamespace +serve :: Var v => Handler () -> Codebase IO v Ann @@ -165,7 +164,7 @@ serveNamespace -> Maybe NamespaceFQN -> Maybe NamespaceFQN -> Handler (APIHeaders NamespaceListing) -serveNamespace tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = +serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = let -- Various helpers errFromEither f = either (throwError . f) pure @@ -222,9 +221,9 @@ serveNamespace tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = let shallowPPE = Backend.basicSuffixifiedNames hashLength root $ Path.fromPath' path' let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' - let listingHash = ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash listingBranch + let listingHash = branchToUnisonHash listingBranch listingEntries <- findShallow listingBranch makeNamespaceListing shallowPPE listingFQN listingHash listingEntries in - addHeaders <$> (tryAuth *> namespaceListing) \ No newline at end of file + addHeaders <$> (tryAuth *> namespaceListing) diff --git a/parser-typechecker/src/Unison/Server/Types.hs b/parser-typechecker/src/Unison/Server/Types.hs index e8708e72f5..a5f43a3898 100644 --- a/parser-typechecker/src/Unison/Server/Types.hs +++ b/parser-typechecker/src/Unison/Server/Types.hs @@ -30,6 +30,9 @@ import Unison.Codebase.Editor.DisplayObject ( DisplayObject, ) import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Hash as Hash +import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.ShortBranchHash ( ShortBranchHash (..), ) @@ -207,6 +210,8 @@ instance ToSchema Doc.SpecialForm where instance ToSchema Doc.Src where instance ToSchema a => ToSchema (Doc.Ref a) where +-- Helpers + munge :: Text -> LZ.ByteString munge = Text.encodeUtf8 . Text.fromStrict @@ -222,8 +227,12 @@ defaultWidth = 80 discard :: Applicative m => a -> m () discard = const $ pure () -mayDefault :: Maybe Width -> Width -mayDefault = fromMaybe defaultWidth +mayDefaultWidth :: Maybe Width -> Width +mayDefaultWidth = fromMaybe defaultWidth addHeaders :: v -> APIHeaders v addHeaders = addHeader "*" . addHeader "public" + +branchToUnisonHash :: Branch.Branch m -> UnisonHash +branchToUnisonHash b = + ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash b diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 8ee43dd277..a349d42829 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -128,7 +128,8 @@ library Unison.Server.Doc Unison.Server.Endpoints.FuzzyFind Unison.Server.Endpoints.GetDefinitions - Unison.Server.Endpoints.ListNamespace + Unison.Server.Endpoints.NamespaceDetails + Unison.Server.Endpoints.NamespaceListing Unison.Server.Errors Unison.Server.QueryResult Unison.Server.SearchResult From f8bfe5404e276832d53f8367d53caf6607776606 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 31 Aug 2021 13:29:34 -0400 Subject: [PATCH 034/148] Make transcript tests depend on building unison exe --- parser-typechecker/package.yaml | 2 ++ parser-typechecker/unison-parser-typechecker.cabal | 2 ++ 2 files changed, 4 insertions(+) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index ab978bbfc8..a8876956b6 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -203,6 +203,8 @@ executables: - text - unison-core1 - unison-parser-typechecker + build-tools: + - unison-parser-typechecker:unison benchmarks: runtime: diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 99266cb3bf..031cbf459c 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -404,6 +404,8 @@ executable transcripts TupleSections TypeApplications ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -threaded -rtsopts -with-rtsopts=-N -v0 + build-tools: + unison build-depends: base , directory From 11103673b6b9ce7a9cc7106afe247d261e7373a4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 31 Aug 2021 15:24:37 -0400 Subject: [PATCH 035/148] Fix calling convention of delay.impl --- .../src/Unison/Runtime/Builtin.hs | 30 +++++++++++++++---- unison-src/transcripts-using-base/fix2358.md | 18 +++++++++++ .../transcripts-using-base/fix2358.output.md | 26 ++++++++++++++++ 3 files changed, 68 insertions(+), 6 deletions(-) create mode 100644 unison-src/transcripts-using-base/fix2358.md create mode 100644 unison-src/transcripts-using-base/fix2358.output.md diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 2d21623517..458c145505 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1090,10 +1090,10 @@ boxBoxTo0 instr (arg1, arg2) = fresh2 -- Nat -> () -natToUnit :: ForeignOp -natToUnit = inNat arg nat result (TCon Ty.unitRef 0 []) - where - (arg, nat, result) = fresh3 +-- natToUnit :: ForeignOp +-- natToUnit = inNat arg nat result (TCon Ty.unitRef 0 []) +-- where +-- (arg, nat, result) = fresh3 -- a -> Bool boxToBool :: ForeignOp @@ -1233,12 +1233,29 @@ boxBoxToEFBox = inBxBx arg1 arg2 result where (arg1, arg2, result, stack1, stack2, fail) = fresh6 --- a -> Nat -> Either Failure +-- a -> Nat -> Either Failure b boxNatToEFBox :: ForeignOp boxNatToEFBox = inBxNat arg1 arg2 nat result $ outIoFail stack1 stack2 fail result where (arg1, arg2, nat, stack1, stack2, fail, result) = fresh7 +-- Nat -> Either Failure () +natToEFUnit :: ForeignOp +natToEFUnit + = inNat arg nat result + . TMatch result . MatchSum $ mapFromList + [ (0, ([BX, BX],) + . TAbss [stack1, stack2] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) + $ TCon eitherReference 0 [fail]) + , (1, ([],) + . TLetD unit BX (TCon Ty.unitRef 0 []) + $ TCon eitherReference 1 [unit]) + + ] + where + (arg, nat, result, fail, stack1, stack2, unit) = fresh7 + -- a -> Either b c boxToEBoxBox :: ForeignOp boxToEBoxBox instr @@ -1595,7 +1612,8 @@ declareForeigns = do declareForeign "IO.kill.impl.v3" boxTo0 $ mkForeignIOF killThread - declareForeign "IO.delay.impl.v3" natToUnit $ mkForeignIOF threadDelay + declareForeign "IO.delay.impl.v3" natToEFUnit + $ mkForeignIOF threadDelay declareForeign "IO.stdHandle" standard'handle . mkForeign $ \(n :: Int) -> case n of diff --git a/unison-src/transcripts-using-base/fix2358.md b/unison-src/transcripts-using-base/fix2358.md new file mode 100644 index 0000000000..ff37a70789 --- /dev/null +++ b/unison-src/transcripts-using-base/fix2358.md @@ -0,0 +1,18 @@ + +Tests a former error due to bad calling conventions on delay.impl + +```ucm:hide +.> builtins.mergeio +``` + +```unison +timingApp2 : '{IO, Exception} () +timingApp2 _ = + printLine "Hello" + delay 10 + printLine "World" +``` + +```ucm +.> run timingApp2 +``` diff --git a/unison-src/transcripts-using-base/fix2358.output.md b/unison-src/transcripts-using-base/fix2358.output.md new file mode 100644 index 0000000000..c4d87c9fbb --- /dev/null +++ b/unison-src/transcripts-using-base/fix2358.output.md @@ -0,0 +1,26 @@ + +Tests a former error due to bad calling conventions on delay.impl + +```unison +timingApp2 : '{IO, Exception} () +timingApp2 _ = + printLine "Hello" + delay 10 + printLine "World" +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + timingApp2 : '{IO, Exception} () + +``` +```ucm +.> run timingApp2 + +``` From cdb4fe9326afadd54225770971a81c03346b2565 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 31 Aug 2021 15:25:24 -0400 Subject: [PATCH 036/148] Missed transcript base changes --- unison-src/transcripts-using-base/base.u | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/unison-src/transcripts-using-base/base.u b/unison-src/transcripts-using-base/base.u index 0b32ce5059..7e0b90ab9d 100644 --- a/unison-src/transcripts-using-base/base.u +++ b/unison-src/transcripts-using-base/base.u @@ -136,6 +136,11 @@ stdout = IO.stdHandle StdOut printText : Text -> {io2.IO} Either Failure () printText t = putBytes.impl stdout (toUtf8 t) +printLine : Text -> {io2.IO, Exception} () +printLine t = reraise (printText (t ++ "\n")) + +delay : Nat ->{IO, Exception} () +delay n = reraise (delay.impl n) -- Run tests which might fail, might create temporary directores and Stream out -- results, returns the Results and the result of the test evalTest: '{Stream Result, TempDirs, io2.IO, Exception} a ->{io2.IO, Exception}([Result], a) From aa7c634524f5aaa81c365dbb0cbfe79b0c62c347 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 31 Aug 2021 13:25:03 -0700 Subject: [PATCH 037/148] adds tests for openOrCreateCodebase and introduces types to help --- .../src/Unison/Codebase/Init.hs | 47 +++++++---- parser-typechecker/tests/Suite.hs | 2 + .../tests/Unison/Test/CodebaseInit.hs | 78 +++++++++++++++++++ parser-typechecker/tests/Unison/Test/Ucm.hs | 1 + .../unison-parser-typechecker.cabal | 1 + parser-typechecker/unison/Main.hs | 5 +- 6 files changed, 116 insertions(+), 18 deletions(-) create mode 100644 parser-typechecker/tests/Unison/Test/CodebaseInit.hs diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index a556c0c60d..f0a2a81968 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -12,10 +12,23 @@ import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P -import UnliftIO.Directory (canonicalizePath) +import UnliftIO.Directory (canonicalizePath, getHomeDirectory) type Pretty = P.Pretty P.ColorText +-- CodebaseDir is used to help pass around a Home directory that isn't the +-- actual home directory of the user. Useful in tests. +data CodebaseDir = Home CodebasePath | Specified CodebasePath + +homeOrSpecifiedDir :: Maybe CodebasePath -> IO CodebaseDir +homeOrSpecifiedDir specifiedDir = do + homeDir <- getHomeDirectory + pure $ maybe (Home homeDir) Specified specifiedDir + +codebaseDirToCodebasePath :: CodebaseDir -> CodebasePath +codebaseDirToCodebasePath (Home dir) = dir +codebaseDirToCodebasePath (Specified dir) = dir + data CreateCodebaseError = CreateCodebaseAlreadyExists | CreateCodebaseOther Pretty @@ -32,7 +45,7 @@ data Init m v a = Init codebasePath :: CodebasePath -> CodebasePath } -type FinalizerAndCodebase m v a = (m (), Codebase m v a) +type FinalizerAndCodebase m v a = (m (), Codebase m v a) data InitError = NoCodebaseFoundAtSpecifiedDir @@ -42,26 +55,28 @@ data InitError data InitResult m v a = OpenedCodebase CodebasePath (FinalizerAndCodebase m v a) | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) - | Error CodebasePath InitError + | Error CodebasePath InitError + -openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> Maybe CodebasePath -> m (InitResult m v a) -openOrCreateCodebase cbInit debugName maybeSpecificedDir = do - resolvedDir <- Codebase.getCodebaseDir maybeSpecificedDir - openCodebase cbInit debugName resolvedDir >>= \case -- calls accessor function Init -> debug name -> blah blah - Right cb -> pure (OpenedCodebase resolvedDir cb) +openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseDir -> m (InitResult m v a) +openOrCreateCodebase cbInit debugName codebaseDir = do + let resolvedPath = (codebaseDirToCodebasePath codebaseDir) + openCodebase cbInit debugName resolvedPath >>= \case + Right cb -> pure (OpenedCodebase resolvedPath cb) Left _ -> - case maybeSpecificedDir of - Nothing -> do - ifM (FCC.codebaseExists resolvedDir) - (do pure (Error resolvedDir FoundV1Codebase)) + case codebaseDir of + Home homeDir -> do + ifM (FCC.codebaseExists homeDir) + (do pure (Error homeDir FoundV1Codebase)) (do -- Create V2 codebase if neither a V1 or V2 exists - createCodebase cbInit debugName resolvedDir >>= \case - Left errorMessage -> do pure (Error resolvedDir (CouldntCreateCodebase errorMessage)) + createCodebase cbInit debugName homeDir >>= \case + Left errorMessage -> do + pure (Error homeDir (CouldntCreateCodebase errorMessage)) Right cb -> do - pure (CreatedCodebase resolvedDir cb) + pure (CreatedCodebase homeDir cb) ) - Just specifiedDir -> do + Specified specifiedDir -> do ifM (FCC.codebaseExists specifiedDir) (pure (Error specifiedDir FoundV1Codebase)) (pure (Error specifiedDir NoCodebaseFoundAtSpecifiedDir)) diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index 512e8760cb..83be32e8df 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -40,6 +40,7 @@ import qualified Unison.Test.MCode as MCode import qualified Unison.Test.VersionParser as VersionParser import qualified Unison.Test.GitSync as GitSync import qualified Unison.Test.Codebase.Upgrade12 as Upgrade12 +import qualified Unison.Test.CodebaseInit as CodebaseInit -- import qualified Unison.Test.BaseUpgradePushPullTest as BaseUpgradePushPullTest test :: Test () @@ -79,6 +80,7 @@ test = tests , VersionParser.test , Pretty.test , PinBoard.test + , CodebaseInit.test ] main :: IO () diff --git a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs new file mode 100644 index 0000000000..caf03130f6 --- /dev/null +++ b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} + +module Unison.Test.CodebaseInit where + +import EasyTest +import qualified Unison.Codebase.Init as CI +import Unison.Codebase.Init +import qualified System.IO.Temp as Temp + +-- keep it off for CI, since the random temp dirs it generates show up in the +-- output, which causes the test output to change, and the "no change" check +-- to fail +writeTranscriptOutput :: Bool +writeTranscriptOutput = False + +test :: Test () +test = scope "Codebase.Init" $ tests + [ scope "*without* a --codebase flag" $ tests + [ scope "a v2 codebase should be opened" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp)) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + , scope "a v2 codebase should be created when one does not exist" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp) ) + case res of + CI.CreatedCodebase _ _ -> expect True + _ -> expect False + ] + , scope "*with* a --codebase flag" $ tests + [ scope "a v2 codebase should be opened" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified tmp)) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + , scope "a v2 codebase should be *not* created when one does not exist at the Specified dir" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified tmp) ) + case res of + CI.Error _ CI.NoCodebaseFoundAtSpecifiedDir -> expect True + _ -> expect False + ] + ] + +-- Test helpers + +initMockWithCodebase :: IO (Init IO v a) +initMockWithCodebase = do + let codebase = error "did we /actually/ need a Codebase?" + pure $ Init { + -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + openCodebase = (\_ _ -> pure ( Right (pure (), codebase))), + -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + createCodebase' = (\_ _ -> pure (Right (pure (), codebase))), + -- CodebasePath -> CodebasePath + codebasePath = id + } + +initMockWithoutCodebase :: IO (Init IO v a) +initMockWithoutCodebase = do + let codebase = error "did we /actually/ need a Codebase?" + pure $ Init { + -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), + openCodebase = (\_ _ -> pure (Left "no codebase found")), + -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), + createCodebase' = (\_ _ -> pure (Right (pure (), codebase))), + -- CodebasePath -> CodebasePath + codebasePath = id + } \ No newline at end of file diff --git a/parser-typechecker/tests/Unison/Test/Ucm.hs b/parser-typechecker/tests/Unison/Test/Ucm.hs index 01349f6588..5d7972ef7f 100644 --- a/parser-typechecker/tests/Unison/Test/Ucm.hs +++ b/parser-typechecker/tests/Unison/Test/Ucm.hs @@ -11,6 +11,7 @@ module Unison.Test.Ucm CodebaseFormat (..), Transcript, unTranscript, + Codebase (..), ) where diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 99266cb3bf..d43a0ef49c 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -309,6 +309,7 @@ executable tests Unison.Test.Codebase.FileCodebase Unison.Test.Codebase.Path Unison.Test.Codebase.Upgrade12 + Unison.Test.CodebaseInit Unison.Test.ColorText Unison.Test.Common Unison.Test.DataDeclaration diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 264aa21da3..147e518b79 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -283,11 +283,12 @@ defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) getCodebase :: Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebase maybeSpecifiedDir = +getCodebase maybeSpecifiedDir = do -- Likely we should only change codebase format 2? Or both? -- Notes for selves: create a function 'openOrCreateCodebase' which handles v1/v2 codebase provided / no codebase specified -- encode error messages as types. Our spike / idea is below: - CodebaseInit.openOrCreateCodebase SC.init "main" maybeSpecifiedDir >>= \case + codebaseDir <- CodebaseInit.homeOrSpecifiedDir maybeSpecifiedDir + CodebaseInit.openOrCreateCodebase SC.init "main" codebaseDir >>= \case Error dir error -> let message = do From 502bff603e55ef7e508ebcee60514cd376e3ea7d Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 31 Aug 2021 13:28:08 -0700 Subject: [PATCH 038/148] I AM A CONTRIBUTOR! --- CONTRIBUTORS.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 6df1e3285b..febd40be52 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -57,3 +57,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha * Simon Højberg (@hojberg) * David Smith (@shmish111) * Chris Penner (@ChrisPenner) +* Rebecca Mark (@rlmark) From fbb62e3b6a060afe581538e34dd54b26fcdaa54c Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 31 Aug 2021 18:01:51 -0500 Subject: [PATCH 039/148] Simplified fetching the Readme doc for a namespace --- .../src/Unison/Server/Backend.hs | 33 +++++-------------- 1 file changed, 9 insertions(+), 24 deletions(-) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 2fc02987b4..5dafb99534 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -258,27 +258,6 @@ findShallow codebase path' = do Nothing -> pure [] Just b -> findShallowInBranch codebase b -findShallowReadmeInBranch :: - (Monad m, Var v) => - Codebase m v Ann -> - Branch m -> - Backend m (Maybe (TermEntry v Ann)) -findShallowReadmeInBranch codebase branch = - let find :: [ShallowListEntry v Ann] -> Maybe (TermEntry v Ann) - find entries = - case entries of - [] -> Nothing - e : rest -> - case e of - ShallowTermEntry termEntry@(TermEntry _ segment _ _) -> - if (Text.toUpper . HQ'.toText $ segment) == "README" - then Just termEntry - else find rest - _ -> - find rest - in fmap find (findShallowInBranch codebase branch) - - findShallowReadmeInBranchAndRender :: Var v => Width -> @@ -291,15 +270,21 @@ findShallowReadmeInBranchAndRender width runtime codebase branch = printNames = getCurrentPrettyNames (Path.fromList []) branch - renderReadme ppe (TermEntry r _ _ _) = do + renderReadme ppe r = do res <- renderDoc ppe width runtime codebase (Referent.toReference r) pure $ case res of (_, _, doc) : _ -> Just doc _ -> Nothing + + -- allow any of these capitalizations + toCheck = NameSegment <$> ["README", "Readme", "ReadMe", "readme" ] + readmes :: Set Referent + readmes = foldMap lookup toCheck + where lookup seg = R.lookupRan seg rel + rel = Star3.d1 (Branch._terms (Branch.head branch)) in do hqLen <- liftIO $ Codebase.hashLength codebase - readmeTerm <- findShallowReadmeInBranch codebase branch - join <$> traverse (renderReadme (ppe hqLen)) readmeTerm + join <$> traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes) termListEntry From c53031db2f3638bb52775b40a9f850e4c25f9c97 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 31 Aug 2021 16:38:13 -0700 Subject: [PATCH 040/148] fixing imports --- .../src/Unison/Codebase/Init.hs | 26 +++++++------------ .../src/Unison/Codebase/SqliteCodebase.hs | 1 - parser-typechecker/tests/Suite.hs | 1 - .../unison-parser-typechecker.cabal | 4 --- parser-typechecker/unison/Main.hs | 1 - 5 files changed, 10 insertions(+), 23 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 2e783af36b..456e59aea3 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -4,30 +4,29 @@ module Unison.Codebase.Init ( Init (..), DebugName, + InitError (..), + CodebaseDir (..), + InitResult (..), Pretty, createCodebase, initCodebaseAndExit, + openOrCreateCodebase, openNewUcmCodebaseOrExit, + homeOrSpecifiedDir ) where -import Unison.Codebase.Init.Type import System.Exit (exitFailure) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.FileCodebase.Common as FCC -import Unison.Parser (Ann) +import qualified Unison.Codebase.FileCodebase as FCC +import Unison.Parser.Ann (Ann(..)) import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import UnliftIO.Directory (canonicalizePath, getHomeDirectory) -import qualified Unison.Codebase.Init.CreateCodebaseError as E -import Unison.Codebase.Init.CreateCodebaseError (Pretty) - -type DebugName = String - -type Pretty = P.Pretty P.ColorText +import Unison.Codebase.Init.CreateCodebaseError -- CodebaseDir is used to help pass around a Home directory that isn't the -- actual home directory of the user. Useful in tests. @@ -42,10 +41,6 @@ codebaseDirToCodebasePath :: CodebaseDir -> CodebasePath codebaseDirToCodebasePath (Home dir) = dir codebaseDirToCodebasePath (Specified dir) = dir -data CreateCodebaseError - = CreateCodebaseAlreadyExists - | CreateCodebaseOther Pretty - type DebugName = String data Init m v a = Init @@ -70,7 +65,6 @@ data InitResult m v a | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) | Error CodebasePath InitError - openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseDir -> m (InitResult m v a) openOrCreateCodebase cbInit debugName codebaseDir = do let resolvedPath = (codebaseDirToCodebasePath codebaseDir) @@ -98,11 +92,11 @@ createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Eit createCodebase cbInit debugName path = do prettyDir <- P.string <$> canonicalizePath path createCodebase' cbInit debugName path <&> mapLeft \case - E.CreateCodebaseAlreadyExists -> + CreateCodebaseAlreadyExists -> P.wrap $ "It looks like there's already a codebase in: " <> prettyDir - E.CreateCodebaseOther message -> + CreateCodebaseOther message -> P.wrap ("I ran into an error when creating the codebase in: " <> prettyDir) <> P.newline <> P.newline diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 8eeefe3d80..46dc0f0abd 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -75,7 +75,6 @@ import Unison.Codebase.Editor.Git (gitIn, gitTextIn, pullBranch) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteGitRepo), printWriteRepo, writeToRead) import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Init as Codebase -import qualified Unison.Codebase.Init as Codebase1 import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 import Unison.Codebase.Patch (Patch) import qualified Unison.Codebase.Reflog as Reflog diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index b15343cf01..0569323a64 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -37,7 +37,6 @@ import qualified Unison.Test.ANF as ANF import qualified Unison.Test.MCode as MCode import qualified Unison.Test.VersionParser as VersionParser import qualified Unison.Test.GitSync as GitSync -import qualified Unison.Test.Codebase.Upgrade12 as Upgrade12 import qualified Unison.Test.CodebaseInit as CodebaseInit -- import qualified Unison.Test.BaseUpgradePushPullTest as BaseUpgradePushPullTest diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 33f451a869..a716ef8a5f 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -320,11 +320,7 @@ executable tests Unison.Test.ClearCache Unison.Test.Codebase.Causal Unison.Test.Codebase.Path -<<<<<<< HEAD - Unison.Test.Codebase.Upgrade12 Unison.Test.CodebaseInit -======= ->>>>>>> trunk Unison.Test.ColorText Unison.Test.Common Unison.Test.DataDeclaration diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 9367b3f32b..56002fb258 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -28,7 +28,6 @@ import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) -import Unison.Codebase.FileCodebase as FC import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR From 04132eda48df32353a17ab673864c795212dd55a Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 31 Aug 2021 22:14:27 -0500 Subject: [PATCH 041/148] `cd ..` and `up` commands --- .../src/Unison/Codebase/Editor/HandleInput.hs | 5 +++++ parser-typechecker/src/Unison/Codebase/Editor/Input.hs | 1 + .../src/Unison/CommandLine/InputPatterns.hs | 9 +++++++++ 3 files changed, 15 insertions(+) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 664581b5f8..1256b6509f 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -453,6 +453,7 @@ loop = do PreviewMergeLocalBranchI{} -> wat DiffNamespaceI{} -> wat SwitchBranchI{} -> wat + UpI{} -> wat PopBranchI{} -> wat NamesI{} -> wat TodoI{} -> wat @@ -878,6 +879,10 @@ loop = do branch' <- getAt path when (Branch.isEmpty branch') (respond $ CreatedNewBranch path) + UpI -> use currentPath >>= \p -> case Path.unsnoc (Path.unabsolute p) of + Nothing -> pure () + Just (path,_) -> currentPathStack %= Nel.cons (Path.Absolute path) + PopBranchI -> use (currentPathStack . to Nel.uncons) >>= \case (_, Nothing) -> respond StartOfCurrentPathHistory (_, Just t) -> currentPathStack .= t diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 08cc450885..8f51773f61 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -61,6 +61,7 @@ data Input -- Does it make sense to fork from not-the-root of a Github repo? -- change directory | SwitchBranchI Path' + | UpI | PopBranchI -- > names foo -- > names foo.bar diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index 7d99236f92..dc02bbaef0 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -561,6 +561,13 @@ aliasMany = InputPattern "alias.many" ["copy"] _ -> Left (I.help aliasMany) ) +up :: InputPattern +up = InputPattern "up" [] [] + (P.wrapColumn2 [ (makeExample up [], "move current path up one level") ]) + (\case + [] -> Right Input.UpI + _ -> Left (I.help up) + ) cd :: InputPattern cd = InputPattern "namespace" ["cd", "j"] [(Required, pathArg)] @@ -570,6 +577,7 @@ cd = InputPattern "namespace" ["cd", "j"] [(Required, pathArg)] , (makeExample cd [".cat.dog"], "sets the current namespace to the abolute namespace .cat.dog.") ]) (\case + [".."] -> Right Input.UpI [p] -> first fromString $ do p <- Path.parsePath' p pure . Input.SwitchBranchI $ p @@ -1396,6 +1404,7 @@ validInputs = , createPullRequest , loadPullRequest , cd + , up , back , deleteBranch , renameBranch From 4180614ca4443dcfa5bf05c3149f2db8de227c29 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Wed, 1 Sep 2021 09:29:20 -0600 Subject: [PATCH 042/148] New version of IO.systemTime that returns microseconds as Int --- parser-typechecker/src/Unison/Builtin.hs | 2 +- .../src/Unison/Runtime/Builtin.hs | 25 ++++++++++++++++++- 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 8d05d76a38..afae89a5db 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -558,7 +558,7 @@ ioBuiltins = , ("IO.getBytes.impl.v3", handle --> nat --> iof bytes) , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) - , ("IO.systemTime.impl.v3", unit --> iof nat) + , ("IO.systemTime.impl.v3", unit --> iof int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 2d21623517..d960885891 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -977,6 +977,19 @@ outIoFailNat stack1 stack2 stack3 fail nat result = $ TCon eitherReference 1 [nat]) ] +outIoFailInt :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v +outIoFailInt stack1 stack2 stack3 fail int result = + TMatch result . MatchSum $ mapFromList + [ (0, ([BX, BX],) + . TAbss [stack1, stack2] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) + $ TCon eitherReference 0 [fail]) + , (1, ([UN],) + . TAbs stack3 + . TLetD int BX (TCon Ty.intRef 0 [stack3]) + $ TCon eitherReference 1 [int]) + ] + outIoFailBox :: forall v. Var v => v -> v -> v -> v -> ANormal v outIoFailBox stack1 stack2 fail result = TMatch result . MatchSum $ mapFromList @@ -1061,6 +1074,12 @@ unitToEFNat = inUnit unit result $ outIoFailNat stack1 stack2 stack3 fail nat result where (unit, stack1, stack2, stack3, fail, nat, result) = fresh7 +-- () -> Either Failure Int +unitToEFInt :: ForeignOp +unitToEFInt = inUnit unit result + $ outIoFailInt stack1 stack2 stack3 fail int result + where (unit, stack1, stack2, stack3, fail, int, result) = fresh7 + -- () -> Either Failure a unitToEFBox :: ForeignOp unitToEFBox = inUnit unit result @@ -1513,8 +1532,12 @@ declareForeigns = do $ \(h,n) -> Bytes.fromArray <$> hGet h n declareForeign "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h,bs) -> hPut h (Bytes.toArray bs) + declareForeign "IO.systemTime.impl.v3" unitToEFNat - $ mkForeignIOF $ \() -> getPOSIXTime + $ mkForeignIOF $ \() -> getPOSIXTime + + declareForeign "IO.systemTime.impl.v4" unitToEFInt + $ mkForeignIOF $ \() -> fmap (1e6 *) getPOSIXTime declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox $ mkForeignIOF $ \() -> getTemporaryDirectory From f252f4f39d5434df86d84f4eae7e267ca8b29086 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Wed, 1 Sep 2021 16:22:09 -0700 Subject: [PATCH 043/148] Add missing Eq case for Pattern.Char fixes: #2345 --- unison-core/src/Unison/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/unison-core/src/Unison/Pattern.hs b/unison-core/src/Unison/Pattern.hs index 2c7a2e96de..909288615d 100644 --- a/unison-core/src/Unison/Pattern.hs +++ b/unison-core/src/Unison/Pattern.hs @@ -125,6 +125,7 @@ instance H.Hashable (Pattern p) where instance Eq (Pattern loc) where Unbound _ == Unbound _ = True Var _ == Var _ = True + Char _ c == Char _ d = c == d Boolean _ b == Boolean _ b2 = b == b2 Int _ n == Int _ m = n == m Nat _ n == Nat _ m = n == m From 7574ce3c32f4c712aa2df15adb289df6356bf78d Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Wed, 1 Sep 2021 17:34:19 -0700 Subject: [PATCH 044/148] add regression tests --- .../transcripts/pattern-pretty-print-2345.md | 73 ++++++++ .../pattern-pretty-print-2345.output.md | 167 ++++++++++++++++++ 2 files changed, 240 insertions(+) create mode 100644 unison-src/transcripts/pattern-pretty-print-2345.md create mode 100644 unison-src/transcripts/pattern-pretty-print-2345.output.md diff --git a/unison-src/transcripts/pattern-pretty-print-2345.md b/unison-src/transcripts/pattern-pretty-print-2345.md new file mode 100644 index 0000000000..83cb13d7af --- /dev/null +++ b/unison-src/transcripts/pattern-pretty-print-2345.md @@ -0,0 +1,73 @@ +Regression test for https://github.com/unisonweb/unison/pull/2377 + + +```ucm:hide +.> builtins.merge +``` + +```unison +structural ability Ab where + a: Nat -> () + +dopey = cases + ?0 -> () + +grumpy = cases + d -> () + +happy = cases + true -> () + +sneezy = cases + +1 -> () + +bashful = cases + Some a -> () + +mouthy = cases + [] -> () + +pokey = cases + h +: t -> () + +sleepy = cases + i :+ l -> () + +demure = cases + [0] -> () + +angry = cases + a ++ [] -> () + +tremulous = cases + (0,1) -> () + +throaty = cases + { Ab.a a -> k } -> () + +agitated = cases + a | a == 2 -> () + +doc = cases + y@4 -> () +``` + +```ucm +.> add +.> view dopey +.> view grumpy +.> view happy +.> view sneezy +.> view bashful +.> view mouthy +.> view pokey +.> view sleepy +.> view demure +.> view angry +.> view tremulous +.> view throaty +.> view agitated +.> view doc + +``` + diff --git a/unison-src/transcripts/pattern-pretty-print-2345.output.md b/unison-src/transcripts/pattern-pretty-print-2345.output.md new file mode 100644 index 0000000000..ae9732ea4d --- /dev/null +++ b/unison-src/transcripts/pattern-pretty-print-2345.output.md @@ -0,0 +1,167 @@ +Regression test for https://github.com/unisonweb/unison/pull/2377 + + +```unison +structural ability Ab where + a: Nat -> () + +dopey = cases + ?0 -> () + +grumpy = cases + d -> () + +happy = cases + true -> () + +sneezy = cases + +1 -> () + +bashful = cases + Some a -> () + +mouthy = cases + [] -> () + +pokey = cases + h +: t -> () + +sleepy = cases + i :+ l -> () + +demure = cases + [0] -> () + +angry = cases + a ++ [] -> () + +tremulous = cases + (0,1) -> () + +throaty = cases + { Ab.a a -> k } -> () + +agitated = cases + a | a == 2 -> () + +doc = cases + y@4 -> () +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : p4kl4dn7b41 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {Ab} x -> () + tremulous : (Nat, Nat) -> () + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + structural ability Ab + agitated : Nat -> () + angry : [t] -> () + bashful : Optional a -> () + demure : [Nat] -> () + doc : Nat -> () + dopey : Char -> () + grumpy : p4kl4dn7b41 -> () + happy : Boolean -> () + mouthy : [t] -> () + pokey : [t] -> () + sleepy : [t] -> () + sneezy : Int -> () + throaty : Request {Ab} x -> () + tremulous : (Nat, Nat) -> () + +.> view dopey + + dopey : Char -> () + dopey = cases ?0 -> () + +.> view grumpy + + grumpy : p4kl4dn7b41 -> () + grumpy = cases d -> () + +.> view happy + + happy : Boolean -> () + happy = cases true -> () + +.> view sneezy + + sneezy : Int -> () + sneezy = cases +1 -> () + +.> view bashful + + bashful : Optional a -> () + bashful = cases Some a -> () + +.> view mouthy + + mouthy : [t] -> () + mouthy = cases [] -> () + +.> view pokey + + pokey : [t] -> () + pokey = cases h +: t -> () + +.> view sleepy + + sleepy : [t] -> () + sleepy = cases i :+ l -> () + +.> view demure + + demure : [Nat] -> () + demure = cases [0] -> () + +.> view angry + + angry : [t] -> () + angry = cases a ++ [] -> () + +.> view tremulous + + tremulous : (Nat, Nat) -> () + tremulous = cases (0, 1) -> () + +.> view throaty + + throaty : Request {Ab} x -> () + throaty = cases {a a -> k} -> () + +.> view agitated + + agitated : Nat -> () + agitated = cases a | a == 2 -> () + +.> view doc + + doc : Nat -> () + doc = cases y@4 -> () + +``` From a5b978daab3b93b2989e3412bbabed58efdfa3bc Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 2 Sep 2021 16:35:13 -0400 Subject: [PATCH 045/148] Fix some order dependence in `pruneAbilities` - Previously the results could depend on the order that wanted abilities were tested against provided abilities. The new approach runs until a fixed point is reached, allowing some unifications on concrete abilities to better inform the overall process. --- .../src/Unison/Typechecker/Context.hs | 60 +++++++++++++------ unison-src/transcripts/fix2378.md | 44 ++++++++++++++ unison-src/transcripts/fix2378.output.md | 59 ++++++++++++++++++ 3 files changed, 145 insertions(+), 18 deletions(-) create mode 100644 unison-src/transcripts/fix2378.md create mode 100644 unison-src/transcripts/fix2378.output.md diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 2313c5b8b6..2fdd13e4b6 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -2220,6 +2220,37 @@ expandWanted . (traverse.traverse) applyM +pruneConcrete + :: Var v + => Ord loc + => (Maybe (Term v loc) -> Type v loc -> M v loc ()) + -> Wanted v loc + -> Wanted v loc + -> [Type v loc] + -> M v loc (Wanted v loc) +pruneConcrete _ acc [] _ = pure (reverse acc) +pruneConcrete missing acc ((loc, w):ws) have + | Just v <- find (headMatch w) have = do + subtype v w `orElse` missing loc w + ws <- expandWanted ws + have <- expandAbilities have + pruneConcrete missing acc ws have + | otherwise = pruneConcrete missing ((loc,w):acc) ws have + +pruneVariables + :: Var v + => Ord loc + => Wanted v loc + -> Wanted v loc + -> M v loc (Wanted v loc) +pruneVariables acc [] = pure $ reverse acc +pruneVariables acc ((loc,v):vs) = do + discard <- defaultAbility v + vs <- expandWanted vs + if discard + then pruneVariables acc vs + else pruneVariables ((loc,v):acc) vs + pruneAbilities :: Var v => Ord loc @@ -2228,8 +2259,17 @@ pruneAbilities -> M v loc (Wanted v loc) pruneAbilities want0 have0 | debugShow ("pruneAbilities", want0, have0) = undefined -pruneAbilities want0 have0 - = go [] (sortBy (comparing (isVar.snd)) want0) have0 +pruneAbilities want0 have0 = do + pwant <- pruneConcrete missing [] want0 have0 + if pwant /= want0 + then do + want <- expandWanted pwant + have <- expandAbilities have0 + pruneAbilities want have + else -- fixed point + if dflt + then expandWanted =<< pruneVariables [] pwant + else pure pwant where isVar (Type.Var' _) = True isVar _ = False @@ -2246,22 +2286,6 @@ pruneAbilities want0 have0 dflt = not $ any isExistential have0 - go acc [] _ = pure acc - go acc ((loc, w):want) have - | Just v <- find (headMatch w) have = do - subtype v w `orElse` missing loc w - want <- expandWanted want - have <- expandAbilities have - go acc want have - | dflt = do - discard <- defaultAbility w - want <- expandWanted want - have <- expandAbilities have - if discard - then go acc want have - else go ((loc, w):acc) want have - | otherwise = go ((loc, w):acc) want have - subAbilities :: Var v => Ord loc diff --git a/unison-src/transcripts/fix2378.md b/unison-src/transcripts/fix2378.md new file mode 100644 index 0000000000..d4358c26e9 --- /dev/null +++ b/unison-src/transcripts/fix2378.md @@ -0,0 +1,44 @@ + +Tests for an ability failure that was caused by order dependence of +checking wanted vs. provided abilities. It was necessary to re-check +rows until a fixed point is reached. + +```ucm:hide +.> builtins.merge +``` + +```unison +unique ability C c where + new : c a + receive : c a -> a + send : a -> c a -> () + +unique ability A t g where + fork : '{A t g, g, Exception} a -> t a + await : t a -> a + +unique ability Ex where raise : () -> x + +Ex.catch : '{Ex, g} a ->{g} Either () a +Ex.catch _ = todo "Exception.catch" + +C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r +C.pure.run _ = todo "C.pure.run" + +A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a +A.pure.run _ = todo "A.pure.run" + +ex : '{C c, A t {C c}} Nat +ex _ = + c = C.new + x = A.fork 'let + a = receive c + a + 10 + y = A.fork 'let + send 0 c + () + A.await x + +x : '{} (Either () Nat) +x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) +``` diff --git a/unison-src/transcripts/fix2378.output.md b/unison-src/transcripts/fix2378.output.md new file mode 100644 index 0000000000..e7d94119fd --- /dev/null +++ b/unison-src/transcripts/fix2378.output.md @@ -0,0 +1,59 @@ + +Tests for an ability failure that was caused by order dependence of +checking wanted vs. provided abilities. It was necessary to re-check +rows until a fixed point is reached. + +```unison +unique ability C c where + new : c a + receive : c a -> a + send : a -> c a -> () + +unique ability A t g where + fork : '{A t g, g, Exception} a -> t a + await : t a -> a + +unique ability Ex where raise : () -> x + +Ex.catch : '{Ex, g} a ->{g} Either () a +Ex.catch _ = todo "Exception.catch" + +C.pure.run : (forall c . '{C c, g} r) ->{Ex, g} r +C.pure.run _ = todo "C.pure.run" + +A.pure.run : (forall t . '{A t g, g} a) ->{Ex,g} a +A.pure.run _ = todo "A.pure.run" + +ex : '{C c, A t {C c}} Nat +ex _ = + c = C.new + x = A.fork 'let + a = receive c + a + 10 + y = A.fork 'let + send 0 c + () + A.await x + +x : '{} (Either () Nat) +x _ = Ex.catch '(C.pure.run '(A.pure.run ex)) +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique ability A t g + unique ability C c + unique ability Ex + A.pure.run : (∀ t. '{g, A t g} a) ->{g, Ex} a + C.pure.run : (∀ c. '{g, C c} r) ->{g, Ex} r + Ex.catch : '{g, Ex} a ->{g} Either () a + ex : '{C c, A t {C c}} Nat + x : 'Either () Nat + +``` From 7ea5b8b96018a2b97ec4b0919c863436dd3286b8 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 2 Sep 2021 18:55:27 -0500 Subject: [PATCH 046/148] Fix #2353 --- parser-typechecker/src/Unison/FileParser.hs | 14 +++++++---- unison-core/src/Unison/Names3.hs | 8 +++---- unison-core/src/Unison/Term.hs | 5 ++-- unison-src/transcripts/fix2353.md | 16 +++++++++++++ unison-src/transcripts/fix2353.output.md | 26 +++++++++++++++++++++ 5 files changed, 59 insertions(+), 10 deletions(-) create mode 100644 unison-src/transcripts/fix2353.md create mode 100644 unison-src/transcripts/fix2353.output.md diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index b2acb739be..75598b1805 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -1,5 +1,6 @@ {-# Language DeriveTraversable #-} {-# Language OverloadedStrings #-} +{-# Language ViewPatterns #-} module Unison.FileParser where @@ -8,7 +9,9 @@ import Unison.Prelude import qualified Unison.ABT as ABT import Control.Lens import Control.Monad.Reader (local, asks) +import Data.List.Extra (nubOrd) import qualified Data.Map as Map +import qualified Data.Set as Set import Prelude hiding (readFile) import qualified Text.Megaparsec as P import Unison.DataDeclaration (DataDeclaration, EffectDeclaration) @@ -92,8 +95,9 @@ file = do -- suffix, but `bob` is. `foo.alice` and `bob.alice` are both unique suffixes but -- they map to themselves, so we ignore them. In our example, we'll just be left with -- [(bob, Term.var() zonk.bob)] - replacements = [ (Name.toVar n, Term.var() v') | (n,[v']) <- Map.toList varsBySuffix - , Name.toVar n /= v' ] + replacements = [ (Name.toVar n, Term.var() v') + | (n, nubOrd -> [v']) <- Map.toList varsBySuffix + , Name.toVar n /= v' ] locals = Map.keys varsBySuffix -- This will perform the actual variable replacements for suffixes -- that uniquely identify definitions in the file. It will avoid @@ -101,10 +105,12 @@ file = do -- `bob -> bob * 42`, `bob` will correctly refer to the lambda parameter. -- and not the `zonk.bob` declared in the file. resolveLocals = ABT.substsInheritAnnotation replacements - terms <- case List.validate (traverse $ Term.bindSomeNames curNames . resolveLocals) terms of + let bindNames = Term.bindSomeNames avoid curNames . resolveLocals + where avoid = Set.fromList (stanzas0 >>= getVars) + terms <- case List.validate (traverse bindNames) terms of Left es -> resolutionFailures (toList es) Right terms -> pure terms - watches <- case List.validate (traverse . traverse $ Term.bindSomeNames curNames . resolveLocals) watches of + watches <- case List.validate (traverse . traverse $ bindNames) watches of Left es -> resolutionFailures (toList es) Right ws -> pure ws let toPair (tok, _) = (L.payload tok, ann tok) diff --git a/unison-core/src/Unison/Names3.hs b/unison-core/src/Unison/Names3.hs index 7cb26cdc79..d768f452e4 100644 --- a/unison-core/src/Unison/Names3.hs +++ b/unison-core/src/Unison/Names3.hs @@ -311,13 +311,13 @@ expandWildcardImport prefix ns = pure (suffix, full) -- Deletes from the `n0 : Names0` any definitions whose names --- share a suffix with a name in `ns`. Does so using logarithmic --- time lookups, traversing only `ns`. +-- are in `ns`. Does so using logarithmic time lookups, +-- traversing only `ns`. -- -- See usage in `FileParser` for handling precendence of symbol -- resolution where local names are preferred to codebase names. shadowSuffixedTerms0 :: [Name] -> Names0 -> Names0 shadowSuffixedTerms0 ns n0 = names0 terms' (types0 n0) where - shadowedBy name = Name.searchBySuffix name (terms0 n0) - terms' = R.subtractRan (foldMap shadowedBy ns) (terms0 n0) + terms' = foldl' go (terms0 n0) ns + go ts name = R.deleteDom name ts diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index bac9ff746d..765f8b991d 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -146,7 +146,8 @@ bindNames keepFreeTerms ns0 e = do -- lookup. Any terms not found in the `Names0` are kept free. bindSomeNames :: forall v a . Var v - => Names0 + => Set v + -> Names0 -> Term v a -> Names.ResolutionResult v a (Term v a) -- bindSomeNames ns e | trace "Term.bindSome" False @@ -158,7 +159,7 @@ bindSomeNames -- || traceShow (freeVars e) False -- || traceShow e False -- = undefined -bindSomeNames ns e = bindNames varsToTDNR ns e where +bindSomeNames avoid ns e = bindNames (avoid <> varsToTDNR) ns e where -- `Term.bindNames` takes a set of variables that are not substituted. -- These should be the variables that will be subject to TDNR, which -- we compute as the set of variables whose names cannot be found in `ns`. diff --git a/unison-src/transcripts/fix2353.md b/unison-src/transcripts/fix2353.md new file mode 100644 index 0000000000..8c6c05c2de --- /dev/null +++ b/unison-src/transcripts/fix2353.md @@ -0,0 +1,16 @@ +```ucm:hide +.> builtins.merge +``` + +```unison +use builtin Scope +unique ability Async t g where async : Nat +unique ability Exception where raise : Nat -> x + +pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a +pure.run a0 a = + a' : forall s . '{Scope s, Exception, g} a + a' = 'a0 -- typechecks + -- make sure this builtin can still be referenced + Scope.run a' +``` diff --git a/unison-src/transcripts/fix2353.output.md b/unison-src/transcripts/fix2353.output.md new file mode 100644 index 0000000000..aa8bae78a4 --- /dev/null +++ b/unison-src/transcripts/fix2353.output.md @@ -0,0 +1,26 @@ +```unison +use builtin Scope +unique ability Async t g where async : Nat +unique ability Exception where raise : Nat -> x + +pure.run : a -> (forall t . '{Async t g} a) ->{Exception, g} a +pure.run a0 a = + a' : forall s . '{Scope s, Exception, g} a + a' = 'a0 -- typechecks + -- make sure this builtin can still be referenced + Scope.run a' +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique ability Async t g + unique ability Exception + pure.run : a -> (∀ t. '{Async t g} a) ->{g, Exception} a + +``` From eb483a32ebaeaa2272a5bb64ccdaeba736295311 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 2 Sep 2021 20:59:40 -0500 Subject: [PATCH 047/148] rename function --- parser-typechecker/src/Unison/FileParser.hs | 2 +- unison-core/src/Unison/Names3.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index 75598b1805..925d61448d 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -76,7 +76,7 @@ file = do -- suffixified local term bindings shadow any same-named thing from the outer codebase scope -- example: `foo.bar` in local file scope will shadow `foo.bar` and `bar` in codebase scope let (curNames, resolveLocals) = - ( Names.shadowSuffixedTerms0 locals (Names.currentNames names) + ( Names.shadowTerms0 locals (Names.currentNames names) , resolveLocals ) where -- All locally declared term variables, running example: diff --git a/unison-core/src/Unison/Names3.hs b/unison-core/src/Unison/Names3.hs index d768f452e4..246e82d0bf 100644 --- a/unison-core/src/Unison/Names3.hs +++ b/unison-core/src/Unison/Names3.hs @@ -316,8 +316,8 @@ expandWildcardImport prefix ns = -- -- See usage in `FileParser` for handling precendence of symbol -- resolution where local names are preferred to codebase names. -shadowSuffixedTerms0 :: [Name] -> Names0 -> Names0 -shadowSuffixedTerms0 ns n0 = names0 terms' (types0 n0) +shadowTerms0 :: [Name] -> Names0 -> Names0 +shadowTerms0 ns n0 = names0 terms' (types0 n0) where terms' = foldl' go (terms0 n0) ns go ts name = R.deleteDom name ts From d75d37a8212d8d09cb0d27b3c68650e21343e75b Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 3 Sep 2021 10:43:14 -0400 Subject: [PATCH 048/148] Fix some errors --- parser-typechecker/src/Unison/Typechecker/Context.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 2fdd13e4b6..0c1bfeabe6 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -57,7 +57,6 @@ import Data.Functor.Compose ( Compose(..) ) import Data.List import Data.List.NonEmpty ( NonEmpty ) import qualified Data.Map as Map -import Data.Ord ( comparing ) import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty ( NESeq ) import qualified Data.Sequence.NonEmpty as NESeq @@ -2271,9 +2270,6 @@ pruneAbilities want0 have0 = do then expandWanted =<< pruneVariables [] pwant else pure pwant where - isVar (Type.Var' _) = True - isVar _ = False - isExistential (Type.Var' TypeVar.Existential{}) = True isExistential _ = False From 02759823803e846295ee6a8eab360d3ff73a983e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 6 Sep 2021 20:15:59 -0400 Subject: [PATCH 049/148] update to lts-18.9, ghc 8.10.7 --- stack.yaml | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/stack.yaml b/stack.yaml index eabcc02872..be3ad64b32 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ packages: - codebase2/util-term #compiler-check: match-exact -resolver: lts-18.6 +resolver: lts-18.9 extra-deps: - github: unisonweb/configurator @@ -35,18 +35,8 @@ extra-deps: - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- random-1.2.0 -# remove these when stackage upgrades containers -# (these = containers 0.6.4, text-1.2.4, binary-0.8.8, parsec-3.1.14, Cabal-3.2.1.0) -# see https://github.com/unisonweb/unison/pull/1807#issuecomment-777069869 -- containers-0.6.4.1 -- text-1.2.4.1 -- binary-0.8.8.0 -- parsec-3.1.14.0 -- Cabal-3.2.1.0 - fuzzyfind-3.0.0 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 -- optparse-applicative-0.16.1.0 # We need some features from the most recent revision ghc-options: # All packages From 7cdc02299397c8464efd410e9d15c8a140a6b134 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 7 Sep 2021 13:57:34 -0500 Subject: [PATCH 050/148] Testing harness for round-trip parsing/pretty-printing testing --- .../src/Unison/Codebase/TranscriptParser.hs | 4 + unison-src/transcripts/round-trip.md | 60 +++++++ unison-src/transcripts/round-trip.output.md | 153 ++++++++++++++++++ 3 files changed, 217 insertions(+) create mode 100644 unison-src/transcripts/round-trip.md create mode 100644 unison-src/transcripts/round-trip.output.md diff --git a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs index b6690d5d15..500fc3f392 100644 --- a/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs +++ b/parser-typechecker/src/Unison/Codebase/TranscriptParser.hs @@ -158,6 +158,10 @@ run dir configFile stanzas codebase = do -- end of ucm block Just Nothing -> do output "\n```\n" + -- We clear the file cache after each `ucm` stanza, so + -- that `load` command can read the file written by `edit` + -- rather than hitting the cache. + writeIORef unisonFiles Map.empty dieUnexpectedSuccess awaitInput -- ucm command to run diff --git a/unison-src/transcripts/round-trip.md b/unison-src/transcripts/round-trip.md new file mode 100644 index 0000000000..454db1a555 --- /dev/null +++ b/unison-src/transcripts/round-trip.md @@ -0,0 +1,60 @@ +This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added here as regression tests. Add tests at the bottom of this + +```ucm:hide +.> builtins.mergeio +.> load unison-src/transcripts-using-base/base.u +``` + +## How to use this transcript: checking round-trip for inline definitions + +```unison:hide +x = 1 + 1 +``` + +```ucm +.> add +.> edit x +.> reflog +.> reset-root 2 +``` + +Resetting the namespace after each example ensures they don't interact at all, which is probably what you want. + +The `load` command which does parsing and typechecking of the `edit`'d definitions needs to be in a separate stanza from the `edit` command. + +```ucm +.> load scratch.u +``` + +## How to use this transcript: checking round-trip for definitions from a file + +Examples can also be loaded from `.u` files: + +```ucm +.> load unison-src/transcripts/round-trip/ex2.u +.> add +``` + +When loading definitions from a file, an empty stanza like this will ensure that this empty file is where the definitions being `edit`'d will get dumped. + +```unison:hide +-- empty scratch file, `edit` will target this +``` + +Without the above stanza, the `edit` will send the definition to the most recently loaded file, which would be `ex2.u`, making the transcript not idempotent. + +```ucm +.> edit b +.> reflog +.> reset-root 2 +``` + +```ucm +.> load scratch.u +``` + +No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11` in the transcript to load all the definitions into the file. + +## Example 1 + +Add tests here diff --git a/unison-src/transcripts/round-trip.output.md b/unison-src/transcripts/round-trip.output.md new file mode 100644 index 0000000000..fa05afb85d --- /dev/null +++ b/unison-src/transcripts/round-trip.output.md @@ -0,0 +1,153 @@ +This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added here as regression tests. Add tests at the bottom of this + +## How to use this transcript: checking round-trip for inline definitions + +```unison +x = 1 + 1 +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + x : Nat + +.> edit x + + ☝️ + + I added these definitions to the top of + /Users/pchiusano/unison/scratch.u + + x : Nat + x = + use Nat + + 1 + 1 + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #8rn1an5gj8 : add + 2. #pqvd5behc2 : builtins.mergeio + 3. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +Resetting the namespace after each example ensures they don't interact at all, which is probably what you want. + +The `load` command which does parsing and typechecking of the `edit`'d definitions needs to be in a separate stanza from the `edit` command. + +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : Nat + +``` +## How to use this transcript: checking round-trip for definitions from a file + +Examples can also be loaded from `.u` files: + +```ucm +.> load unison-src/transcripts/round-trip/ex2.u + + I found and typechecked these definitions in + unison-src/transcripts/round-trip/ex2.u. If you do an `add` or + `update`, here's how your codebase would change: + + ⍟ These new definitions are ok to `add`: + + b : Nat + +.> add + + ⍟ I've added these definitions: + + b : Nat + +``` +When loading definitions from a file, an empty stanza like this will ensure that this empty file is where the definitions being `edit`'d will get dumped. + +```unison +-- empty scratch file, `edit` will target this +``` + +Without the above stanza, the `edit` will send the definition to the most recently loaded file, which would be `ex2.u`, making the transcript not idempotent. + +```ucm +.> edit b + + ☝️ + + I added these definitions to the top of + /Users/pchiusano/unison/scratch.u + + b : Nat + b = 92384 + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #dbvse9969b : add + 2. #pqvd5behc2 : reset-root #pqvd5behc2 + 3. #8rn1an5gj8 : add + 4. #pqvd5behc2 : builtins.mergeio + 5. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + b : Nat + +``` +No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11 in the transcript to load all the definitions into the file. + +## Example 1 + +Add tests here From a5dae2dc6090906b3333c5663237d2cf968bd0ed Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 7 Sep 2021 14:15:30 -0500 Subject: [PATCH 051/148] forgot to add the `.u` file --- unison-src/transcripts/round-trip/ex2.u | 1 + 1 file changed, 1 insertion(+) create mode 100644 unison-src/transcripts/round-trip/ex2.u diff --git a/unison-src/transcripts/round-trip/ex2.u b/unison-src/transcripts/round-trip/ex2.u new file mode 100644 index 0000000000..af175c38bb --- /dev/null +++ b/unison-src/transcripts/round-trip/ex2.u @@ -0,0 +1 @@ +b = 92384 From 2ab39a2ac4786e99c4fc3a7bfbf4513353b2c612 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 7 Sep 2021 14:37:24 -0500 Subject: [PATCH 052/148] Tweak to allow CI to pass It now runs the test but doesn't care if the output has changed --- .github/workflows/ci.yaml | 2 ++ .../{transcripts/round-trip => transcripts-round-trip}/ex2.u | 0 .../round-trip.md => transcripts-round-trip/main.md} | 2 +- .../main.output.md} | 4 ++-- 4 files changed, 5 insertions(+), 3 deletions(-) rename unison-src/{transcripts/round-trip => transcripts-round-trip}/ex2.u (100%) rename unison-src/{transcripts/round-trip.md => transcripts-round-trip/main.md} (97%) rename unison-src/{transcripts/round-trip.output.md => transcripts-round-trip/main.output.md} (97%) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 6b28fc6fa1..47c470a1fe 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -83,3 +83,5 @@ jobs: stack --no-terminal exec transcripts git diff x=`git status --porcelain -uno` bash -c 'if [[ -n $x ]]; then echo "$x" && false; fi' + - name: prettyprint-round-trip + run: stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md diff --git a/unison-src/transcripts/round-trip/ex2.u b/unison-src/transcripts-round-trip/ex2.u similarity index 100% rename from unison-src/transcripts/round-trip/ex2.u rename to unison-src/transcripts-round-trip/ex2.u diff --git a/unison-src/transcripts/round-trip.md b/unison-src/transcripts-round-trip/main.md similarity index 97% rename from unison-src/transcripts/round-trip.md rename to unison-src/transcripts-round-trip/main.md index 454db1a555..7ff7039ca6 100644 --- a/unison-src/transcripts/round-trip.md +++ b/unison-src/transcripts-round-trip/main.md @@ -31,7 +31,7 @@ The `load` command which does parsing and typechecking of the `edit`'d definitio Examples can also be loaded from `.u` files: ```ucm -.> load unison-src/transcripts/round-trip/ex2.u +.> load unison-src/transcripts-round-trip/ex2.u .> add ``` diff --git a/unison-src/transcripts/round-trip.output.md b/unison-src/transcripts-round-trip/main.output.md similarity index 97% rename from unison-src/transcripts/round-trip.output.md rename to unison-src/transcripts-round-trip/main.output.md index fa05afb85d..7708035cb6 100644 --- a/unison-src/transcripts/round-trip.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -71,10 +71,10 @@ The `load` command which does parsing and typechecking of the `edit`'d definitio Examples can also be loaded from `.u` files: ```ucm -.> load unison-src/transcripts/round-trip/ex2.u +.> load unison-src/transcripts-round-trip/ex2.u I found and typechecked these definitions in - unison-src/transcripts/round-trip/ex2.u. If you do an `add` or + unison-src/transcripts-round-trip/ex2.u. If you do an `add` or `update`, here's how your codebase would change: ⍟ These new definitions are ok to `add`: From 7b85f45282c32f0e6996dd0415a4e9bcd393a92b Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 7 Sep 2021 15:26:16 -0500 Subject: [PATCH 053/148] Add note on running the pretty-printing round trip tests --- development.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/development.markdown b/development.markdown index 1d9babb2cf..5ef3ca8809 100644 --- a/development.markdown +++ b/development.markdown @@ -21,6 +21,7 @@ On startup, Unison prints a url for the codebase UI. If you did step 3 above, th * `stack exec tests` runs the tests * `stack exec transcripts` runs all the integration tests, found in `unison-src/transcripts`. You can add more tests to this directory. * `stack exec tests -- prefix-of-test` and `stack exec transcripts -- prefix-of-test` only run tests with a matching prefix. +* `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests ### What if you want a profiled build? From 9598005dacbfefbc13075e1f3bd3304b1da507ce Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Wed, 8 Sep 2021 09:44:59 -0700 Subject: [PATCH 054/148] add builtin Term.Link.toText wanted this builtin for log messages which are helping us debug our implementation of Remote --- parser-typechecker/src/Unison/Builtin.hs | 1 + parser-typechecker/src/Unison/Runtime/ANF.hs | 2 +- parser-typechecker/src/Unison/Runtime/Builtin.hs | 7 +++++-- parser-typechecker/src/Unison/Runtime/MCode.hs | 3 ++- parser-typechecker/src/Unison/Runtime/Machine.hs | 11 ++++++++++- 5 files changed, 19 insertions(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index e10a320803..86aac71f5c 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -640,6 +640,7 @@ codeBuiltins = , ("Value.value", forall1 "a" $ \a -> a --> value) , ("Value.load" , forall1 "a" $ \a -> value --> io (eithert (list termLink) a)) + , ("Link.Term.toText", termLink --> text) ] stmBuiltins :: forall v. Var v => [(Text, Type v)] diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index cc0f4cf458..3463fd3513 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -751,7 +751,7 @@ data POp | EQLU | CMPU | EROR -- Code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load - | VALU -- value + | VALU | TLTT -- value, Term.Link.toText -- Debug | PRNT | INFO -- STM diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 458c145505..9e5f016c36 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -738,6 +738,10 @@ code'lookup , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) ] +term'link'to'text :: Var v => SuperNormal v +term'link'to'text + = unop0 0 $ \[link] -> TPrm TLTT [link] + value'load :: Var v => SuperNormal v value'load = unop0 2 $ \[vlu,t,r] @@ -1453,7 +1457,7 @@ builtinLookup , ("Code.lookup", code'lookup) , ("Value.load", value'load) , ("Value.value", value'create) - + , ("Link.Term.toText", term'link'to'text) , ("STM.atomically", stm'atomic) ] ++ foreignWrappers @@ -1796,7 +1800,6 @@ declareForeigns = do . mkForeign $ pure . Bytes.fromArray . serializeValue declareForeign "Value.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeValue . Bytes.toArray - declareForeign "Any.Any" boxDirect . mkForeign $ \(a :: Closure) -> pure $ Closure.DataB1 Ty.anyRef 0 a diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs index 27152f4c0b..2e2000b781 100644 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ b/parser-typechecker/src/Unison/Runtime/MCode.hs @@ -330,7 +330,7 @@ data BPrim1 | FLTB -- flatten -- code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load - | VALU -- value + | VALU | TLTT -- value, Term.Link.toText deriving (Show, Eq, Ord) data BPrim2 @@ -1057,6 +1057,7 @@ emitPOp ANF.CMPU = emitBP2 CMPU emitPOp ANF.MISS = emitBP1 MISS emitPOp ANF.CACH = emitBP1 CACH emitPOp ANF.LKUP = emitBP1 LKUP +emitPOp ANF.TLTT = emitBP1 TLTT emitPOp ANF.LOAD = emitBP1 LOAD emitPOp ANF.VALU = emitBP1 VALU diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 0c5764e54f..73a5de1461 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -34,8 +34,9 @@ import qualified Data.Primitive.PrimArray as PA import Text.Read (readMaybe) import Unison.Builtin.Decls (exceptionRef) -import Unison.Reference (Reference(Builtin)) +import Unison.Reference (Reference(Builtin), toShortHash) import Unison.Referent (pattern Ref) +import qualified Unison.ShortHash as SH import Unison.Symbol (Symbol) import Unison.Runtime.ANF @@ -230,6 +231,13 @@ exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do bstk <- bump bstk bstk <$ pokeBi bstk sg pure (denv, ustk, bstk, k) +exec !_ !denv !ustk !bstk !k (BPrim1 TLTT i) = do + clink <- peekOff bstk i + let Ref link = unwrapForeign $ marshalToForeign clink + let sh = SH.toText $ toShortHash link + bstk <- bump bstk + pokeBi bstk sh + pure (denv, ustk, bstk, k) exec !env !denv !ustk !bstk !k (BPrim1 LOAD i) = do v <- peekOffBi bstk i ustk <- bump ustk @@ -1179,6 +1187,7 @@ bprim1 !ustk !bstk FLTB i = do bprim1 !ustk !bstk MISS _ = pure (ustk, bstk) bprim1 !ustk !bstk CACH _ = pure (ustk, bstk) bprim1 !ustk !bstk LKUP _ = pure (ustk, bstk) +bprim1 !ustk !bstk TLTT _ = pure (ustk, bstk) bprim1 !ustk !bstk LOAD _ = pure (ustk, bstk) bprim1 !ustk !bstk VALU _ = pure (ustk, bstk) {-# inline bprim1 #-} From d1a7692c40163f4459d543cb223d81e6ef85c87b Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 8 Sep 2021 12:01:40 -0500 Subject: [PATCH 055/148] Fix with @dolio to pattern matching on constructors with polymorphic fields Added some more tests --- .../src/Unison/Typechecker/Context.hs | 7 +- unison-src/transcripts/higher-rank.md | 69 ++++++++++ unison-src/transcripts/higher-rank.output.md | 126 ++++++++++++++++++ 3 files changed, 199 insertions(+), 3 deletions(-) create mode 100644 unison-src/transcripts/higher-rank.md create mode 100644 unison-src/transcripts/higher-rank.output.md diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index cbe7294a96..15db6377ca 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1156,7 +1156,8 @@ checkCases scrutType outType cases@(Term.MatchCase _ _ t : _) vt = existentialp lo v appendContext [existential v] subtype (Type.effectV lo (lo, Type.effects lo es) (lo, vt)) sty - coalesceWanteds =<< traverse (checkCase scrutType outType) cases + scrutType' <- ungeneralize scrutType + coalesceWanteds =<< traverse (checkCase scrutType' outType) cases getEffect :: Var v => Ord loc => Reference -> Int -> M v loc (Type v loc) @@ -1220,8 +1221,8 @@ checkPattern -> Pattern loc -> StateT [v] (M v loc) [(v, v)] checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern"::String, tx, ty) False = undefined -checkPattern scrutineeType0 p = - lift (ungeneralize scrutineeType0) >>= \scrutineeType -> case p of +checkPattern scrutineeType p = + case p of Pattern.Unbound _ -> pure [] Pattern.Var _loc -> do v <- getAdvance p diff --git a/unison-src/transcripts/higher-rank.md b/unison-src/transcripts/higher-rank.md new file mode 100644 index 0000000000..ee303a8a45 --- /dev/null +++ b/unison-src/transcripts/higher-rank.md @@ -0,0 +1,69 @@ + +This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. + +```ucm:hide +.> alias.type ##Nat Nat +.> alias.type ##Text Text +.> alias.type ##IO IO +``` + +In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: + +```unison +f : (forall a . a -> a) -> (Nat, Text) +f id = (id 1, id "hi") + +> f (x -> x) +``` + +Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: + +```unison +f : (forall a g . '{g} a -> '{g} a) -> () -> () +f id _ = + (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) + () +``` + +Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: + +```unison +unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) + +Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) +Functor.map = cases Functor f -> f + +Functor.blah : Functor f -> () +Functor.blah = cases Functor f -> + g : forall a b . (a -> b) -> f a -> f b + g = f + () +``` + +This example is similar, but involves abilities: + +```unison +unique ability Remote t where doRemoteStuff : () +unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) + +Loc.blah : Loc -> () +Loc.blah = cases Loc f -> + f0 : '{Remote tx} ax ->{Remote tx} tx ax + f0 = f + () + +-- In this case, no annotation is needed since the lambda +-- is checked against a polymorphic type +Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) + +-- In this case, the annotation is needed since f' is inferred +-- on its own it won't infer the higher-rank type +Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform2 nt = cases Loc f -> + f' : forall t a . '{Remote t} a ->{Remote t} t a + f' a = f (nt a) + Loc f' +``` \ No newline at end of file diff --git a/unison-src/transcripts/higher-rank.output.md b/unison-src/transcripts/higher-rank.output.md new file mode 100644 index 0000000000..5570cddbed --- /dev/null +++ b/unison-src/transcripts/higher-rank.output.md @@ -0,0 +1,126 @@ + +This transcript does some testing of higher-rank types. Regression tests related to higher-rank types can be added here. + +In this example, a higher-rank function is defined, `f`. No annotation is needed at the call-site of `f`, because the lambda is being checked against the polymorphic type `forall a . a -> a`, rather than inferred: + +```unison +f : (forall a . a -> a) -> (Nat, Text) +f id = (id 1, id "hi") + +> f (x -> x) +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : (∀ a. a ->{g} a) ->{g} (Nat, Text) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 4 | > f (x -> x) + ⧩ + (1, "hi") + +``` +Another example, involving abilities. Here the ability-polymorphic function is instantiated with two different ability lists, `{}` and `{IO}`: + +```unison +f : (forall a g . '{g} a -> '{g} a) -> () -> () +f id _ = + (id ('1 : '{} Nat), id ('("hi") : '{IO} Text)) + () +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : (∀ a g. '{g} a ->{h} '{g} a) -> '{h} () + +``` +Here's an example, showing that polymorphic functions can be fields of a constructor, and the functions remain polymorphic even when the field is bound to a name during pattern matching: + +```unison +unique type Functor f = Functor (forall a b . (a -> b) -> f a -> f b) + +Functor.map : Functor f -> (forall a b . (a -> b) -> f a -> f b) +Functor.map = cases Functor f -> f + +Functor.blah : Functor f -> () +Functor.blah = cases Functor f -> + g : forall a b . (a -> b) -> f a -> f b + g = f + () +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique type Functor f + Functor.blah : Functor f -> () + Functor.map : Functor f + -> (∀ a b. (a -> b) -> f a -> f b) + +``` +This example is similar, but involves abilities: + +```unison +unique ability Remote t where doRemoteStuff : () +unique type Loc = Loc (forall t a . '{Remote t} a ->{Remote t} t a) + +Loc.blah : Loc -> () +Loc.blah = cases Loc f -> + f0 : '{Remote tx} ax ->{Remote tx} tx ax + f0 = f + () + +-- In this case, no annotation is needed since the lambda +-- is checked against a polymorphic type +Loc.transform : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform nt = cases Loc f -> Loc (a -> f (nt a)) + +-- In this case, the annotation is needed since f' is inferred +-- on its own it won't infer the higher-rank type +Loc.transform2 : (forall t a . '{Remote t} a -> '{Remote t} a) + -> Loc -> Loc +Loc.transform2 nt = cases Loc f -> + f' : forall t a . '{Remote t} a ->{Remote t} t a + f' a = f (nt a) + Loc f' +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique type Loc + unique ability Remote t + Loc.blah : Loc -> () + Loc.transform : (∀ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc + Loc.transform2 : (∀ t a. '{Remote t} a -> '{Remote t} a) + -> Loc + -> Loc + +``` From 1fd4c9fac5204e0a150671ebda862138b443f9e9 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Wed, 8 Sep 2021 15:57:40 -0700 Subject: [PATCH 056/148] some changes needed for Code deserialization * actually cache intermediate terms * don't try to load the code attached to literal terms when deseralizing terms --- parser-typechecker/src/Unison/Runtime/ANF.hs | 8 ++------ parser-typechecker/src/Unison/Runtime/Machine.hs | 3 ++- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 3463fd3513..7a2db144ec 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -101,7 +101,7 @@ import Unison.Typechecker.Components (minimize') import Unison.Pattern (SeqOp(..)) import qualified Unison.Pattern as P import Unison.Reference (Reference(..)) -import Unison.Referent (Referent, pattern Ref, pattern Con) +import Unison.Referent (Referent) -- For internal errors data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) @@ -1205,12 +1205,8 @@ contLinks f (Mark ps de k) contLinks _ KE = mempty litLinks :: Monoid a => (Bool -> Reference -> a) -> BLit -> a -litLinks _ (Text _) = mempty -litLinks _ (Bytes _) = mempty litLinks f (List s) = foldMap (valueLinks f) s -litLinks f (TmLink (Ref r)) = f False r -litLinks f (TmLink (Con r _ _)) = f True r -litLinks f (TyLink r) = f True r +litLinks _ _ = mempty groupTermLinks :: SuperGroup v -> [Reference] groupTermLinks = Set.toList . groupLinks f diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 73a5de1461..6b50de912f 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -1489,6 +1489,7 @@ cacheAdd0 ntys0 tml cc = atomically $ do let new = M.difference toAdd have sz = fromIntegral $ M.size new (rs,gs) = unzip $ M.toList new + writeTVar (intermed cc) (have <> new) rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 ntm <- stateTVar (freshTm cc) $ \i -> (i, i+sz) rtm <- updateMap (M.fromList $ zip rs [ntm..]) (refTm cc) @@ -1561,7 +1562,7 @@ reflectValue rty = goV = pure (ANF.TmLink l) | Just l <- maybeUnwrapForeign Rf.typeLinkRef f = pure (ANF.TyLink l) - | otherwise = die $ err "foreign value" + | otherwise = die $ err $ "foreign value: " <> (show f) reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Closure) From d9d1d4b91cf276b0acace0687468b8ac4d1a650c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 8 Sep 2021 21:59:01 -0400 Subject: [PATCH 057/148] Add parens to destructuring binds --- parser-typechecker/src/Unison/TermPrinter.hs | 2 +- unison-src/transcripts-round-trip/main.md | 25 +++++- .../transcripts-round-trip/main.output.md | 88 +++++++++++++++++-- 3 files changed, 107 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 72bda10f9d..172dfa7282 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -298,7 +298,7 @@ pretty0 -- know bc.) So we'll fail to take advantage of any opportunity -- this let block provides to add a use statement. Not so bad. (fmt S.ControlKeyword "let") `PP.hang` x - lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) (-1) vs pat)) + lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) 10 vs pat)) <> printGuard guard printGuard Nothing = mempty printGuard (Just g') = let (_,g) = ABT.unabs g' in diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 7ff7039ca6..42930a80cb 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -55,6 +55,27 @@ Without the above stanza, the `edit` will send the definition to the most recent No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11` in the transcript to load all the definitions into the file. -## Example 1 +## Destructuring binds + +Regression test for https://github.com/unisonweb/unison/issues/2337 + +```unison:hide +unique type Blah = Blah Boolean Boolean + +f : Blah -> Boolean +f x = let + (Blah.Blah a b) = x + a +``` + +```ucm +.> add +.> edit Blah f +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` -Add tests here diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 7708035cb6..53e3132845 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -18,7 +18,7 @@ x = 1 + 1 ☝️ I added these definitions to the top of - /Users/pchiusano/unison/scratch.u + /Users/runar/work/unison/scratch.u x : Nat x = @@ -102,7 +102,7 @@ Without the above stanza, the `edit` will send the definition to the most recent ☝️ I added these definitions to the top of - /Users/pchiusano/unison/scratch.u + /Users/runar/work/unison/scratch.u b : Nat b = 92384 @@ -146,8 +146,86 @@ Without the above stanza, the `edit` will send the definition to the most recent b : Nat ``` -No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11 in the transcript to load all the definitions into the file. +No reason you can't load a bunch of definitions from a single `.u` file in one go, the only thing that's annoying is you'll have to `find` and then `edit 1-11` in the transcript to load all the definitions into the file. -## Example 1 +## Destructuring binds -Add tests here +Regression test for https://github.com/unisonweb/unison/issues/2337 + +```unison +unique type Blah = Blah Boolean Boolean + +f : Blah -> Boolean +f x = let + 0 + (Blah.Blah a b) = x + a +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Blah + f : Blah -> Boolean + +.> edit Blah f + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + unique type Blah + = Blah Boolean Boolean + + f : Blah -> Boolean + f x = + 0 + let + (Blah a b) = x + a + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #53gruvtk78 : add + 2. #pqvd5behc2 : reset-root #pqvd5behc2 + 3. #dbvse9969b : add + 4. #pqvd5behc2 : reset-root #pqvd5behc2 + 5. #8rn1an5gj8 : add + 6. #pqvd5behc2 : builtins.mergeio + 7. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique type Blah + f : Blah -> Boolean + +``` From 935c4ed1a011692f9e1981a5c635a848f802f713 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 8 Sep 2021 23:00:48 -0400 Subject: [PATCH 058/148] update test --- parser-typechecker/tests/Unison/Test/TermPrinter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/tests/Unison/Test/TermPrinter.hs b/parser-typechecker/tests/Unison/Test/TermPrinter.hs index d190ab5121..66f21a5b86 100644 --- a/parser-typechecker/tests/Unison/Test/TermPrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TermPrinter.hs @@ -370,7 +370,7 @@ test = scope "termprinter" $ tests , pending $ tc "match x with [a] -> a" -- ditto , pending $ tc "match x with [] -> a" -- ditto , tcDiff "match x with Optional.Some (Optional.Some _) -> ()" - "let\n Optional.Some (Optional.Some _) = x\n ()" + "let\n (Optional.Some (Optional.Some _)) = x\n ()" -- need an actual effect constructor to test the following , pending $ tc "match x with { SomeRequest (Optional.Some _) -> k } -> ()" , tcBinding 50 "foo" (Just "Int") "3" "foo : Int\n\ From 065ced0c18b15875a885412d3135bc9fcc1a8258 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 9 Sep 2021 09:09:24 -0400 Subject: [PATCH 059/148] copying out definition-related classes for hashing purposes copied more than necessary temporarily, to avoid broken project nightmare --- .../src/Unison/Hashing/V1/DataDeclaration.hs | 117 ++ .../Unison/Hashing/V1/LabeledDependency.hs | 56 + .../src/Unison/Hashing/V1/Pattern.hs | 165 +++ .../src/Unison/Hashing/V1/Reference.hs | 192 +++ .../src/Unison/Hashing/V1/Reference/Util.hs | 21 + .../src/Unison/Hashing/V1/Referent.hs | 123 ++ .../src/Unison/Hashing/V1/Term.hs | 1120 +++++++++++++++++ .../src/Unison/Hashing/V1/Type.hs | 708 +++++++++++ .../unison-parser-typechecker.cabal | 8 + 9 files changed, 2510 insertions(+) create mode 100644 parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Pattern.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Reference.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Referent.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Term.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Type.hs diff --git a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs new file mode 100644 index 0000000000..7344274ae5 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# Language DeriveFoldable #-} +{-# Language DeriveTraversable #-} +{-# Language OverloadedStrings #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} + +module Unison.Hashing.V1.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + Modifier(..), + asDataDecl, + constructorType, + constructorTypes, + declConstructorReferents, + declDependencies, + dependencies, + ) +where + +import Unison.Prelude + + +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.Hashing.V1.Type (Type) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Referent' as Referent' +import Prelude hiding (cycle) + +type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) + +data DeclOrBuiltin v a = + Builtin CT.ConstructorType | Decl (Decl v a) + deriving (Eq, Show) + +asDataDecl :: Decl v a -> DataDeclaration v a +asDataDecl = either toDataDecl id + +declDependencies :: Ord v => Decl v a -> Set Reference +declDependencies = either (dependencies . toDataDecl) dependencies + +constructorType :: Decl v a -> CT.ConstructorType +constructorType = \case + Left{} -> CT.Effect + Right{} -> CT.Data + +data Modifier = Structural | Unique Text -- | Opaque (Set Reference) + deriving (Eq, Ord, Show) + +data DataDeclaration v a = DataDeclaration { + modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] +} deriving (Eq, Show, Functor) + +newtype EffectDeclaration v a = EffectDeclaration { + toDataDecl :: DataDeclaration v a +} deriving (Eq,Show,Functor) + +constructorTypes :: DataDeclaration v a -> [Type v a] +constructorTypes = (snd <$>) . constructors + +constructors :: DataDeclaration v a -> [(v, Type v a)] +constructors (DataDeclaration _ _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] + +-- -- This function is unsound, since the `rid` and the `decl` have to match. +-- -- It should probably be hashed directly from the Decl, once we have a +-- -- reliable way of doing that. —AI +-- declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] +-- declConstructorReferents rid decl = +-- [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] +-- where ct = constructorType decl + +constructorIds :: DataDeclaration v a -> [Int] +constructorIds dd = [0 .. length (constructors dd) - 1] + + +dependencies :: Ord v => DataDeclaration v a -> Set Reference +dependencies dd = + Set.unions (Type.dependencies <$> constructorTypes dd) + +data F a + = Type (Type.F a) + | LetRec [a] a + | Constructors [a] + | Modified Modifier a + deriving (Functor, Foldable, Show, Show1) + +instance Hashable1 F where + hash1 hashCycle hash e = + let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +instance Hashable.Hashable Modifier where + tokens Structural = [Hashable.Tag 0] + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs new file mode 100644 index 0000000000..26119dfa4f --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V1.LabeledDependency + ( derivedTerm + , derivedType + , termRef + , typeRef + , referent + , dataConstructor + , effectConstructor + , fold + , referents + , toReference + , LabeledDependency + , partition + ) where + +import Unison.Prelude hiding (fold) + +import qualified Data.Set as Set +import Unison.Hashing.V1.Reference (Id, Reference (DerivedId)) +import Unison.Hashing.V1.Referent (ConstructorId, Referent, pattern Con, pattern Ref) +import Unison.ConstructorType (ConstructorType (Data, Effect)) + +-- dumb constructor name is private +newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) + +derivedType, derivedTerm :: Id -> LabeledDependency +typeRef, termRef :: Reference -> LabeledDependency +referent :: Referent -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency + +derivedType = X . Left . DerivedId +derivedTerm = X . Right . Ref . DerivedId +typeRef = X . Left +termRef = X . Right . Ref +referent = X . Right +dataConstructor r cid = X . Right $ Con r cid Data +effectConstructor r cid = X . Right $ Con r cid Effect + +referents :: Foldable f => f Referent -> Set LabeledDependency +referents rs = Set.fromList (map referent $ toList rs) + +fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a +fold f g (X e) = either f g e + +partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) +partition = partitionEithers . map (\(X e) -> e) . toList + +-- | Left TypeRef | Right TermRef +toReference :: LabeledDependency -> Either Reference Reference +toReference = \case + X (Left r) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs new file mode 100644 index 0000000000..ad0f71db1e --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs @@ -0,0 +1,165 @@ +{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} + +module Unison.Hashing.V1.Pattern where + +import Unison.Prelude + +import Data.Foldable as Foldable hiding (foldMap') +import Data.List (intercalate) +import qualified Data.Set as Set +import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.LabeledDependency as LD +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.Hashable as H + +type ConstructorId = Int + +data Pattern loc + = Unbound loc + | Var loc + | Boolean loc !Bool + | Int loc !Int64 + | Nat loc !Word64 + | Float loc !Double + | Text loc !Text + | Char loc !Char + | Constructor loc !Reference !Int [Pattern loc] + | As loc (Pattern loc) + | EffectPure loc (Pattern loc) + | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | SequenceLiteral loc [Pattern loc] + | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + deriving (Ord,Generic,Functor,Foldable,Traversable) + +data SeqOp = Cons + | Snoc + | Concat + deriving (Eq, Show, Ord, Generic) + +instance H.Hashable SeqOp where + tokens Cons = [H.Tag 0] + tokens Snoc = [H.Tag 1] + tokens Concat = [H.Tag 2] + +instance Show (Pattern loc) where + show (Unbound _ ) = "Unbound" + show (Var _ ) = "Var" + show (Boolean _ x) = "Boolean " <> show x + show (Int _ x) = "Int " <> show x + show (Nat _ x) = "Nat " <> show x + show (Float _ x) = "Float " <> show x + show (Text _ t) = "Text " <> show t + show (Char _ c) = "Char " <> show c + show (Constructor _ r i ps) = + "Constructor " <> unwords [show r, show i, show ps] + show (As _ p) = "As " <> show p + show (EffectPure _ k) = "EffectPure " <> show k + show (EffectBind _ r i ps k) = + "EffectBind " <> unwords [show r, show i, show ps, show k] + show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) + show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt + +application :: Pattern loc -> Bool +application (Constructor _ _ _ (_ : _)) = True +application _ = False + +loc :: Pattern loc -> loc +loc p = head $ Foldable.toList p + +setLoc :: Pattern loc -> loc -> Pattern loc +setLoc p loc = case p of + EffectBind _ a b c d -> EffectBind loc a b c d + EffectPure _ a -> EffectPure loc a + As _ a -> As loc a + Constructor _ a b c -> Constructor loc a b c + SequenceLiteral _ ps -> SequenceLiteral loc ps + SequenceOp _ ph op pt -> SequenceOp loc ph op pt + x -> fmap (const loc) x + +instance H.Hashable (Pattern p) where + tokens (Unbound _) = [H.Tag 0] + tokens (Var _) = [H.Tag 1] + tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] + tokens (Int _ n) = H.Tag 3 : [H.Int n] + tokens (Nat _ n) = H.Tag 4 : [H.Nat n] + tokens (Float _ f) = H.Tag 5 : H.tokens f + tokens (Constructor _ r n args) = + [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] + tokens (EffectPure _ p) = H.Tag 7 : H.tokens p + tokens (EffectBind _ r n args k) = + [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] + tokens (As _ p) = H.Tag 9 : H.tokens p + tokens (Text _ t) = H.Tag 10 : H.tokens t + tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps + tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r + tokens (Char _ c) = H.Tag 13 : H.tokens c + +instance Eq (Pattern loc) where + Unbound _ == Unbound _ = True + Var _ == Var _ = True + Boolean _ b == Boolean _ b2 = b == b2 + Int _ n == Int _ m = n == m + Nat _ n == Nat _ m = n == m + Float _ f == Float _ g = f == g + Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs + EffectPure _ p == EffectPure _ q = p == q + EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 + As _ p == As _ q = p == q + Text _ t == Text _ t2 = t == t2 + SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 + SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 + _ == _ = False + +foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m +foldMap' f p = case p of + Unbound _ -> f p + Var _ -> f p + Boolean _ _ -> f p + Int _ _ -> f p + Nat _ _ -> f p + Float _ _ -> f p + Text _ _ -> f p + Char _ _ -> f p + Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps + As _ p' -> f p <> foldMap' f p' + EffectPure _ p' -> f p <> foldMap' f p' + EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' + SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps + SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 + +generalizedDependencies + :: Ord r + => (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Pattern loc + -> Set r +generalizedDependencies literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . foldMap' + (\case + Unbound _ -> mempty + Var _ -> mempty + As _ _ -> mempty + Constructor _ r cid _ -> [dataType r, dataConstructor r cid] + EffectPure _ _ -> [effectType Type.effectRef] + EffectBind _ r cid _ _ -> + [effectType Type.effectRef, effectType r, effectConstructor r cid] + SequenceLiteral _ _ -> [literalType Type.listRef] + SequenceOp {} -> [literalType Type.listRef] + Boolean _ _ -> [literalType Type.booleanRef] + Int _ _ -> [literalType Type.intRef] + Nat _ _ -> [literalType Type.natRef] + Float _ _ -> [literalType Type.floatRef] + Text _ _ -> [literalType Type.textRef] + Char _ _ -> [literalType Type.charRef] + ) + +-- labeledDependencies :: Pattern loc -> Set LabeledDependency +-- labeledDependencies = generalizedDependencies LD.typeRef +-- LD.dataConstructor +-- LD.typeRef +-- LD.effectConstructor +-- LD.typeRef \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Reference.hs b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs new file mode 100644 index 0000000000..0bcdee547f --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Reference + (Reference, + pattern Builtin, + pattern Derived, + pattern DerivedId, + Id(..), + Pos, + Size, + derivedBase32Hex, + Component, members, + components, + groupByComponent, + componentFor, + unsafeFromText, + idFromText, + isPrefixOf, + fromShortHash, + fromText, + readSuffix, + showShort, + showSuffix, + toId, + toText, + unsafeId, + toShortHash, + idToShortHash) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Unison.Hash as H +import Unison.Hashable as Hashable +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import Data.Char (isDigit) + +-- | Either a builtin or a user defined (hashed) top-level declaration. +-- +-- Used for both terms and types. Doesn't distinguish between them. +-- +-- Other used defined things like local variables don't get @Reference@s. +data Reference + = Builtin Text.Text + -- `Derived` can be part of a strongly connected component. + -- The `Pos` refers to a particular element of the component + -- and the `Size` is the number of elements in the component. + -- Using an ugly name so no one tempted to use this + | DerivedId Id deriving (Eq,Ord,Generic) + +pattern Derived :: H.Hash -> Pos -> Size -> Reference +pattern Derived h i n = DerivedId (Id h i n) + +{-# COMPLETE Builtin, Derived #-} + +-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. +data Id = Id H.Hash Pos Size deriving (Generic) + +unsafeId :: Reference -> Id +unsafeId (Builtin b) = + error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." +unsafeId (DerivedId x) = x + +idToShortHash :: Id -> ShortHash +idToShortHash = toShortHash . DerivedId + +-- todo: move these to ShortHash module? +-- but Show Reference currently depends on SH +toShortHash :: Reference -> ShortHash +toShortHash (Builtin b) = SH.Builtin b +toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing +toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing + where + -- todo: remove `n` parameter; must also update readSuffix + index = Just $ showSuffix i n + +-- toShortHash . fromJust . fromShortHash == id and +-- fromJust . fromShortHash . toShortHash == id +-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it +-- may not be possible to base32Hex decode them. These will return Nothing. +-- Also, ShortHashes that include constructor ids will return Nothing; +-- try Referent.fromShortHash +fromShortHash :: ShortHash -> Maybe Reference +fromShortHash (SH.Builtin b) = Just (Builtin b) +fromShortHash (SH.ShortHash prefix cycle Nothing) = do + h <- H.fromBase32Hex prefix + case cycle of + Nothing -> Just (Derived h 0 1) + Just t -> case Text.splitOn "c" t of + [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) + _ -> Nothing +fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing + +-- (3,10) encoded as "3c10" +-- (0,93) encoded as "0c93" +showSuffix :: Pos -> Size -> Text +showSuffix i n = Text.pack $ show i <> "c" <> show n + +-- todo: don't read or return size; must also update showSuffix and fromText +readSuffix :: Text -> Either String (Pos, Size) +readSuffix t = case Text.breakOn "c" t of + (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> + Right (read (Text.unpack pos), read (Text.unpack size)) + _ -> Left "suffix decoding error" + +isPrefixOf :: ShortHash -> Reference -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +toText :: Reference -> Text +toText = SH.toText . toShortHash + +showShort :: Int -> Reference -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +type Pos = Word64 +type Size = Word64 + +newtype Component = Component { members :: Set Reference } + +-- Gives the component (dependency cycle) that the reference is a part of +componentFor :: Reference -> Component +componentFor b@Builtin {} = Component (Set.singleton b) +componentFor (Derived h _ n) = + Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] + +derivedBase32Hex :: Text -> Pos -> Size -> Reference +derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) + where + msg = error $ "Reference.derivedBase32Hex " <> show h + h = H.fromBase32Hex b32Hex + +unsafeFromText :: Text -> Reference +unsafeFromText = either error id . fromText + +idFromText :: Text -> Maybe Id +idFromText s = case fromText s of + Left _ -> Nothing + Right (Builtin _) -> Nothing + Right (DerivedId id) -> pure id + +toId :: Reference -> Maybe Id +toId (DerivedId id) = Just id +toId Builtin{} = Nothing + +-- examples: +-- `##Text.take` — builtins don’t have cycles +-- `#2tWjVAuc7` — derived, no cycle +-- `#y9ycWkiC1.y9` — derived, part of cycle +-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. +fromText :: Text -> Either String Reference +fromText t = case Text.split (=='#') t of + [_, "", b] -> Right (Builtin b) + [_, h] -> case Text.split (=='.') h of + [hash] -> Right (derivedBase32Hex hash 0 1) + [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix + _ -> bail + _ -> bail + where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t + +component :: H.Hash -> [k] -> [(k, Id)] +component h ks = let + size = fromIntegral (length ks) + in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] + +components :: [(H.Hash, [k])] -> [(k, Id)] +components sccs = uncurry component =<< sccs + +groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] +groupByComponent refs = done $ foldl' insert Map.empty refs + where + insert m (k, r@(Derived h _ _)) = + Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) + insert m (k, r) = + Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) + done m = sortOn snd <$> toList m + +instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId +instance Show Reference where show = SH.toString . SH.take 5 . toShortHash + +instance Hashable.Hashable Reference where + tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] + tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] + +-- | Two references mustn't differ in cycle length only. +instance Eq Id where x == y = compare x y == EQ +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs b/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs new file mode 100644 index 0000000000..e954492f44 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Reference/Util.hs @@ -0,0 +1,21 @@ +module Unison.Hashing.V1.Reference.Util where + +import Unison.Prelude + +import qualified Unison.Hashing.V1.Reference as Reference +import Unison.Hashable (Hashable1) +import Unison.ABT (Var) +import qualified Unison.ABT as ABT +import qualified Data.Map as Map + +hashComponents :: + (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) + => (Reference.Id -> ABT.Term f v ()) + -> Map v (ABT.Term f v a) + -> Map v (Reference.Id, ABT.Term f v a) +hashComponents embedRef tms = + Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) + + diff --git a/parser-typechecker/src/Unison/Hashing/V1/Referent.hs b/parser-typechecker/src/Unison/Hashing/V1/Referent.hs new file mode 100644 index 0000000000..b5a5035ebe --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Referent.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V1.Referent where + +import Unison.Prelude +import Unison.Referent' ( Referent'(..), toReference' ) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as R +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH + +import Unison.ConstructorType (ConstructorType) +import qualified Unison.ConstructorType as CT + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. +type Referent = Referent' Reference +type ConstructorId = Int +pattern Ref :: Reference -> Referent +pattern Ref r = Ref' r +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent +pattern Con r i t = Con' r i t +{-# COMPLETE Ref, Con #-} + +-- | Cannot be a builtin. +type Id = Referent' R.Id + +-- referentToTerm moved to Term.fromReferent +-- termToReferent moved to Term.toReferent + +-- todo: move these to ShortHash module +toShortHash :: Referent -> ShortHash +toShortHash = \case + Ref r -> R.toShortHash r + Con r i _ -> patternShortHash r i + +toShortHashId :: Id -> ShortHash +toShortHashId = toShortHash . fromId + +-- also used by HashQualified.fromPattern +patternShortHash :: Reference -> ConstructorId -> ShortHash +patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } + +showShort :: Int -> Referent -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +toText :: Referent -> Text +toText = \case + Ref r -> R.toText r + Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) + +ctorTypeText :: CT.ConstructorType -> Text +ctorTypeText CT.Effect = EffectCtor +ctorTypeText CT.Data = DataCtor + +pattern EffectCtor = "a" +pattern DataCtor = "d" + +toString :: Referent -> String +toString = Text.unpack . toText + +isConstructor :: Referent -> Bool +isConstructor Con{} = True +isConstructor _ = False + +toTermReference :: Referent -> Maybe Reference +toTermReference = \case + Ref r -> Just r + _ -> Nothing + +toReference :: Referent -> Reference +toReference = toReference' + +fromId :: Id -> Referent +fromId = fmap R.DerivedId + +toTypeReference :: Referent -> Maybe Reference +toTypeReference = \case + Con r _i _t -> Just r + _ -> Nothing + +isPrefixOf :: ShortHash -> Referent -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +unsafeFromText :: Text -> Referent +unsafeFromText = fromMaybe (error "invalid referent") . fromText + +-- #abc[.xy][#cid] +fromText :: Text -> Maybe Referent +fromText t = either (const Nothing) Just $ + -- if the string has just one hash at the start, it's just a reference + if Text.length refPart == 1 then + Ref <$> R.fromText t + else if Text.all Char.isDigit cidPart then do + r <- R.fromText (Text.dropEnd 1 refPart) + ctorType <- ctorType + let cid = read (Text.unpack cidPart) + pure $ Con r cid ctorType + else + Left ("invalid constructor id: " <> Text.unpack cidPart) + where + ctorType = case Text.take 1 cidPart' of + EffectCtor -> Right CT.Effect + DataCtor -> Right CT.Data + _otherwise -> + Left ("invalid constructor type (expected '" + <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') + refPart = Text.dropWhileEnd (/= '#') t + cidPart' = Text.takeWhileEnd (/= '#') t + cidPart = Text.drop 1 cidPart' + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct diff --git a/parser-typechecker/src/Unison/Hashing/V1/Term.hs b/parser-typechecker/src/Unison/Hashing/V1/Term.hs new file mode 100644 index 0000000000..27ee4fdbb2 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Term.hs @@ -0,0 +1,1120 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Term where + +import Unison.Prelude + +import Prelude hiding (and,or) +import Control.Monad.State (evalState) +import qualified Control.Monad.Writer.Strict as Writer +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Sequence as Sequence +import Prelude.Extras (Eq1(..), Show1(..)) +import Text.Show +import qualified Unison.ABT as ABT +import qualified Unison.Blank as B +import qualified Unison.Hash as Hash +import Unison.Hashable (Hashable1, accumulateToken) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V1.Pattern (Pattern) +import qualified Unison.Hashing.V1.Pattern as Pattern +import Unison.Hashing.V1.Reference (Reference, pattern Builtin) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Hashing.V1.Reference.Util as ReferenceUtil +import Unison.Hashing.V1.Referent (Referent) +import qualified Unison.Hashing.V1.Referent as Referent +import Unison.Hashing.V1.Type (Type) +import qualified Unison.Hashing.V1.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Util.List (multimap) +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unsafe.Coerce +import Unison.Symbol (Symbol) +import qualified Unison.Hashing.V1.LabeledDependency as LD +import Unison.Hashing.V1.LabeledDependency (LabeledDependency) + +-- This gets reexported; should maybe live somewhere other than Pattern, though. +type ConstructorId = Pattern.ConstructorId + +data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a + deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) + +-- | Base functor for terms in the Unison language +-- We need `typeVar` because the term and type variables may differ. +data F typeVar typeAnn patternAnn a + = Int Int64 + | Nat Word64 + | Float Double + | Boolean Bool + | Text Text + | Char Char + | Blank (B.Blank typeAnn) + | Ref Reference + -- First argument identifies the data type, + -- second argument identifies the constructor + | Constructor Reference ConstructorId + | Request Reference ConstructorId + | Handle a a + | App a a + | Ann a (Type typeVar typeAnn) + | List (Seq a) + | If a a a + | And a a + | Or a a + | Lam a + -- Note: let rec blocks have an outer ABT.Cycle which introduces as many + -- variables as there are bindings + | LetRec IsTop [a] a + -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + | Let IsTop a a + -- Pattern matching / eliminating data types, example: + -- case x of + -- Just n -> rhs1 + -- Nothing -> rhs2 + -- + -- translates to + -- + -- Match x + -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- , (Constructor 1 [], rhs2) ] + | Match a [MatchCase patternAnn a] + | TermLink Referent + | TypeLink Reference + deriving (Foldable,Functor,Generic,Generic1,Traversable) + +type IsTop = Bool + +-- | Like `Term v`, but with an annotation of type `a` at every level in the tree +type Term v a = Term2 v a a v a +-- | Allow type variables and term variables to differ +type Term' vt v a = Term2 vt a a v a +-- | Allow type variables, term variables, type annotations and term annotations +-- to all differ +type Term2 vt at ap v a = ABT.Term (F vt at ap) v a +-- | Like `Term v a`, but with only () for type and pattern annotations. +type Term3 v a = Term2 v () () v a + +-- | Terms are represented as ABTs over the base functor F, with variables in `v` +type Term0 v = Term v () +-- | Terms with type variables in `vt`, and term variables in `v` +type Term0' vt v = Term' vt v () + +-- Prepare a term for type-directed name resolution by replacing +-- any remaining free variables with blanks to be resolved by TDNR +prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b +prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t + where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = + Just $ resolve (a, bound) a (Text.unpack $ Var.name v) + f _ = Nothing + +amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 +amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) + +patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a +patternMap f = go where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ + MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) + -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a +vmap f = ABT.vmap f . typeMap (ABT.vmap f) + +vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a +vtmap f = typeMap (ABT.vmap f) + +typeMap + :: Ord vt2 + => (Type vt at -> Type vt2 at2) + -> Term2 vt at ap v a + -> Term2 vt2 at2 ap v a +typeMap f = go + where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) + -- Safe since `Ann` is only ctor that has embedded `Type v` arg + -- otherwise we'd have to manually match on every non-`Ann` ctor + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +extraMap' + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> Term2 vt at ap v a + -> Term2 vt' at' ap' v a +extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) + +extraMap + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> F vt at ap a + -> F vt' at' ap' a +extraMap vtf atf apf = \case + Int x -> Int x + Nat x -> Nat x + Float x -> Float x + Boolean x -> Boolean x + Text x -> Text x + Char x -> Char x + Blank x -> Blank (fmap atf x) + Ref x -> Ref x + Constructor x y -> Constructor x y + Request x y -> Request x y + Handle x y -> Handle x y + App x y -> App x y + Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) + List x -> List x + If x y z -> If x y z + And x y -> And x y + Or x y -> Or x y + Lam x -> Lam x + LetRec x y z -> LetRec x y z + Let x y z -> Let x y z + Match tm l -> Match tm (map (matchCaseExtraMap apf) l) + TermLink r -> TermLink r + TypeLink r -> TypeLink r + +matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a +matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y + +unannotate + :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v +unannotate = go + where + go :: Term2 vt at ap v a -> Term0' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v ) = ABT.var v + go (ABT.Tm' f ) = case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + +wrapV :: Ord v => Term v a -> Term (ABT.V v) a +wrapV = vmap ABT.Bound + +-- | All variables mentioned in the given term. +-- Includes both term and type variables, both free and bound. +allVars :: Ord v => Term v a -> Set v +allVars tm = Set.fromList $ + ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] + where + allTypes tm = case tm of + Ann' e tp -> tp : allTypes e + _ -> foldMap allTypes $ ABT.out tm + +freeVars :: Term' vt v a -> Set v +freeVars = ABT.freeVars + +freeTypeVars :: Ord vt => Term' vt v a -> Set vt +freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t + +freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] +freeTypeVarAnnotations e = multimap $ go Set.empty e where + go bound tm = case tm of + Var' _ -> mempty + Ann' e (Type.stripIntroOuters -> t1) -> let + bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs + _ -> bound + in go bound' e <> ABT.freeVarOccurrences bound t1 + ABT.Tm' f -> foldMap (go bound) f + (ABT.out -> ABT.Abs _ body) -> go bound body + (ABT.out -> ABT.Cycle body) -> go bound body + _ -> error "unpossible" + +substTypeVars :: (Ord v, Var vt) + => [(vt, Type vt b)] + -> Term' vt v a + -> Term' vt v a +substTypeVars subs e = foldl' go e subs where + go e (vt, t) = substTypeVar vt t e + +-- Capture-avoiding substitution of a type variable inside a term. This +-- will replace that type variable wherever it appears in type signatures of +-- the term, avoiding capture by renaming ∀-binders. +substTypeVar + :: (Ord v, ABT.Var vt) + => vt + -> Type vt b + -> Term' vt v a + -> Term' vt v a +substTypeVar vt ty = go Set.empty where + go bound tm | Set.member vt bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where + fvs = ABT.freeVars ty + -- if the ∀ introduces a variable, v, which is free in `ty`, we pick a new + -- variable name for v which is unique, v', and rename v to v' in e. + uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let + v = ABT.variable body + v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v + t2 = ABT.bindInheritAnnotation body (Type.var() v2) + in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 + uncapture vs e t0 = let + t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a +renameTypeVar old new = go Set.empty where + go bound tm | Set.member old bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> let + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.rename old new (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- Converts free variables to bound variables using forall or introOuter. Example: +-- +-- foo : x -> x +-- foo a = +-- r : x +-- r = a +-- r +-- +-- This becomes: +-- +-- foo : ∀ x . x -> x +-- foo a = +-- r : outer x . x -- FYI, not valid syntax +-- r = a +-- r +-- +-- More specifically: in the expression `e : t`, unbound lowercase variables in `t` +-- are bound with foralls, and any ∀-quantified type variables are made bound in +-- `e` and its subexpressions. The result is a term with no lowercase free +-- variables in any of its type signatures, with outer references represented +-- with explicit `introOuter` binders. The resulting term may have uppercase +-- free variables that are still unbound. +generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a +generalizeTypeSignatures = go Set.empty where + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e (Type.generalizeLowercase bound -> t) -> let + bound' = case Type.unForalls t of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + in ann loc (go bound' e) (Type.freeVarsToOuters bound t) + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- nicer pattern syntax + +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst +pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) +pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) +pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) +pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) +pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) +pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) +pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) +pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) +pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) +pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) +pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) +pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) +pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) +pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) +pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) +pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) +pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) +pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) +pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) +pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) +pattern Apps' f args <- (unApps -> Just (f, args)) +-- begin pretty-printer helper patterns +pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) +pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) +pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) +pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +-- end pretty-printer helper patterns +pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) +pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) +pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) + +pattern Delay' body <- (unDelay -> Just body) +unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) +unDelay tm = case ABT.out tm of + ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) + | Set.notMember v (ABT.freeVars body) + -> Just body + _ -> Nothing + +pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) +pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) +pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) +pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) +pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) +pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) +pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) +pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) +pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) +pattern Lets' bs e <- (unLet -> Just (bs, e)) +pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) +pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) +pattern LetRec' subst <- (unLetRec -> Just (_, subst)) +pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) +pattern LetRecNamedAnnotatedTop' top ann bs e <- + (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) + +fresh :: Var v => Term0 v -> v -> v +fresh = ABT.fresh + +-- some smart constructors + +var :: a -> v -> Term2 vt at ap v a +var = ABT.annotatedVar + +var' :: Var v => Text -> Term0' vt v +var' = var() . Var.named + +ref :: Ord v => a -> Reference -> Term2 vt at ap v a +ref a r = ABT.tm' a (Ref r) + +pattern Referent' r <- (unReferent -> Just r) + +unReferent :: Term2 vt at ap v a -> Maybe Referent +unReferent (Ref' r) = Just $ Referent.Ref r +unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data +unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect +unReferent _ = Nothing + +refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Referent -> Term2 vt at ap v a +termLink a r = ABT.tm' a (TermLink r) + +typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a +typeLink a r = ABT.tm' a (TypeLink r) + +builtin :: Ord v => a -> Text -> Term2 vt at ap v a +builtin a n = ref a (Reference.Builtin n) + +float :: Ord v => a -> Double -> Term2 vt at ap v a +float a d = ABT.tm' a (Float d) + +boolean :: Ord v => a -> Bool -> Term2 vt at ap v a +boolean a b = ABT.tm' a (Boolean b) + +int :: Ord v => a -> Int64 -> Term2 vt at ap v a +int a d = ABT.tm' a (Int d) + +nat :: Ord v => a -> Word64 -> Term2 vt at ap v a +nat a d = ABT.tm' a (Nat d) + +text :: Ord v => a -> Text -> Term2 vt at ap v a +text a = ABT.tm' a . Text + +char :: Ord v => a -> Char -> Term2 vt at ap v a +char a = ABT.tm' a . Char + +watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a +watch a note e = + apps' (builtin a "Debug.watch") [text a (Text.pack note), e] + +watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a +watchMaybe Nothing e = e +watchMaybe (Just note) e = watch (ABT.annotation e) note e + +blank :: Ord v => a -> Term2 vt at ap v a +blank a = ABT.tm' a (Blank B.Blank) + +placeholder :: Ord v => a -> String -> Term2 vt a ap v a +placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) + +resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at +resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) + +constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +constructor a ref n = ABT.tm' a (Constructor ref n) + +request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +request a ref n = ABT.tm' a (Request ref n) + +-- todo: delete and rename app' to app +app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v +app_ f arg = ABT.tm (App f arg) + +app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +app a f arg = ABT.tm' a (App f arg) + +match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a +match a scrutinee branches = ABT.tm' a (Match scrutinee branches) + +handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +handle a h block = ABT.tm' a (Handle h block) + +and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +and a x y = ABT.tm' a (And x y) + +or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +or a x y = ABT.tm' a (Or x y) + +list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a +list a es = list' a (Sequence.fromList es) + +list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a +list' a es = ABT.tm' a (List es) + +apps + :: Ord v + => Term2 vt at ap v a + -> [(a, Term2 vt at ap v a)] + -> Term2 vt at ap v a +apps = foldl' (\f (a, t) -> app a f t) + +apps' + :: (Ord v, Semigroup a) + => Term2 vt at ap v a + -> [Term2 vt at ap v a] + -> Term2 vt at ap v a +apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) + +iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +iff a cond t f = ABT.tm' a (If cond t f) + +ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v +ann_ e t = ABT.tm (Ann e t) + +ann :: Ord v + => a + -> Term2 vt at ap v a + -> Type vt at + -> Term2 vt at ap v a +ann a e t = ABT.tm' a (Ann e t) + +-- arya: are we sure we want the two annotations to be the same? +lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a +lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) + +delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a +delay a body = + ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) + +lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam'' vs body = foldr (uncurry lam) body vs + +isLam :: Term2 vt at ap v a -> Bool +isLam t = arity t > 0 + +arity :: Term2 vt at ap v a -> Int +arity (LamNamed' _ body) = 1 + arity body +arity (Ann' e _) = arity e +arity _ = 0 + +unLetRecNamedAnnotated + :: Term' vt v a + -> Maybe + (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) +unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = + Just (isTop, ann, avs `zip` bs, e) +unLetRecNamedAnnotated _ = Nothing + +letRec' + :: (Ord v, Monoid a) + => Bool + -> [(v, Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec' isTop bindings body = + letRec isTop + (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) + [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] + body + +-- Prepend a binding to form a (bigger) let rec. Useful when +-- building up a block incrementally using a right fold. +-- +-- For example: +-- consLetRec (x = 42) "hi" +-- => +-- let rec x = 42 in "hi" +-- +-- consLetRec (x = 42) (let rec y = "hi" in (x,y)) +-- => +-- let rec x = 42; y = "hi" in (x,y) +consLetRec + :: Ord v + => Bool -- isTop parameter + -> a -- annotation for overall let rec + -> (a, v, Term' vt v a) -- the binding + -> Term' vt v a -- the body + -> Term' vt v a +consLetRec isTop a (ab, vb, b) body = case body of + LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body + _ -> letRec isTop a [((ab,vb),b)] body + +letRec + :: Ord v + => Bool + -> a + -> [((a, v), Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec _ _ [] e = e +letRec isTop a bindings e = ABT.cycle' + a + (foldr (uncurry ABT.abs' . fst) z bindings) + where z = ABT.tm' a (LetRec isTop (map snd bindings) e) + + +-- | Smart constructor for let rec blocks. Each binding in the block may +-- reference any other binding in the block in its body (including itself), +-- and the output expression may also reference any binding in the block. +letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v +letRec_ _ [] e = e +letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) + where + z = ABT.tm (LetRec isTop (map snd bindings) e) + +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. +-- todo: delete me +let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v +let1_ isTop bindings e = foldr f e bindings + where + f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) + +-- | annotations are applied to each nested Let expression +let1 + :: Ord v + => IsTop + -> [((a, v), Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1 isTop bindings e = foldr f e bindings + where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) + +let1' + :: (Semigroup a, Ord v) + => IsTop + -> [(v, Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1' isTop bindings e = foldr f e bindings + where + ann = ABT.annotation + f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) + where a = ann b <> ann body + +-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v +-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e + +unLet1 + :: Var v + => Term' vt v a + -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) +unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) +unLet1 _ = Nothing + +-- | Satisfies `unLet (let' bs e) == Just (bs, e)` +unLet + :: Term2 vt at ap v a + -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) +unLet t = fixup (go t) + where + go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of + (env, t) -> ((isTop, v, b) : env, t) + go t = ([], t) + fixup ([], _) = Nothing + fixup bst = Just bst + +-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` +unLetRecNamed + :: Term2 vt at ap v a + -> Maybe + ( IsTop + , [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) + | length vs == length bs = Just (isTop, zip vs bs, e) +unLetRecNamed _ = Nothing + +unLetRec + :: (Monad m, Var v) + => Term2 vt at ap v a + -> Maybe + ( IsTop + , (v -> m v) + -> m + ( [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) + ) +unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just + ( isTop + , \freshen -> do + vs <- sequence [ freshen v | (v, _) <- bs ] + let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) + pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) + ) +unLetRec _ = Nothing + +unApps + :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unApps t = unAppsPred (t, const True) + +-- Same as unApps but taking a predicate controlling whether we match on a given function argument. +unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) + where + go (App' i o) acc | pred o = go i (o:acc) + go _ [] = [] + go fn args = fn:args + +unBinaryApp :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a) +unBinaryApp t = case unApps t of + Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) + _ -> Nothing + +-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" +unBinaryApps + :: Term2 vt at ap v a + -> Maybe + ( [(Term2 vt at ap v a, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unBinaryApps t = unBinaryAppsPred (t, const True) + +-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. +unBinaryAppsPred :: (Term2 vt at ap v a + ,Term2 vt at ap v a -> Bool) + -> Maybe ([(Term2 vt at ap v a, + Term2 vt at ap v a)], + Term2 vt at ap v a) +unBinaryAppsPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + _ -> Nothing + +unLams' + :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLams' t = unLamsPred' (t, const True) + +-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a +-- lambda extraction. +unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLamsOpt' t = case unLams' t of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams', but stops at any variable named `()`, which indicates a +-- delay (`'`) annotation which we want to preserve. +unLamsUntilDelay' + :: Var v + => Term2 vt at ap v a + -> Maybe ([v], Term2 vt at ap v a) +unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams' but taking a predicate controlling whether we match on a given binary function. +unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> + Maybe ([v], Term2 vt at ap v a) +unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of + Nothing -> Just ([v], body) + Just (vs, body) -> Just (v:vs, body) +unLamsPred' _ = Nothing + +unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) +unReqOrCtor (Constructor' r cid) = Just (r, cid) +unReqOrCtor (Request' r cid) = Just (r, cid) +unReqOrCtor _ = Nothing + +-- Dependencies including referenced data and effect decls +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) + +termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +termDependencies = + Set.fromList + . mapMaybe + ( LD.fold + (\_typeRef -> Nothing) + ( Referent.fold + (\termRef -> Just termRef) + (\_typeConRef _i _ct -> Nothing) + ) + ) + . toList + . labeledDependencies + +-- gets types from annotations and constructors +typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +typeDependencies = + Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + +-- Gets the types to which this term contains references via patterns and +-- data constructors. +constructorDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +constructorDependencies = + Set.unions + . generalizedDependencies (const mempty) + (const mempty) + Set.singleton + (const . Set.singleton) + Set.singleton + (const . Set.singleton) + Set.singleton + +generalizedDependencies + :: (Ord v, Ord vt, Ord r) + => (Reference -> r) + -> (Reference -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Term2 vt at ap v a + -> Set r +generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . Writer.execWriter . ABT.visit' f where + f t@(Ref r) = Writer.tell [termRef r] $> t + f t@(TermLink r) = case r of + Referent.Ref r -> Writer.tell [termRef r] $> t + Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t + Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t + f t@(TypeLink r) = Writer.tell [typeRef r] $> t + f t@(Ann _ typ) = + Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t + f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t + f t@(Int _) = Writer.tell [literalType Type.intRef] $> t + f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t + f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t + f t@(Text _) = Writer.tell [literalType Type.textRef] $> t + f t@(List _) = Writer.tell [literalType Type.listRef] $> t + f t@(Constructor r cid) = + Writer.tell [dataType r, dataConstructor r cid] $> t + f t@(Request r cid) = + Writer.tell [effectType r, effectConstructor r cid] $> t + f t@(Match _ cases) = traverse_ goPat cases $> t + f t = pure t + goPat (MatchCase pat _ _) = + Writer.tell . toList $ Pattern.generalizedDependencies literalType + dataConstructor + dataType + effectConstructor + effectType + pat + +labeledDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.termRef + LD.typeRef + LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef + +updateDependencies + :: Ord v + => Map Reference Reference + -> Map Reference Reference + -> Term v a + -> Term v a +updateDependencies termUpdates typeUpdates = ABT.rebuildUp go + where + -- todo: this function might need tweaking if we ever allow type replacements + -- would need to look inside pattern matching and constructor calls + go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) + go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) + go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) + go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp + go f = f + +-- | If the outermost term is a function application, +-- perform substitution of the argument into the body +betaReduce :: Var v => Term0 v -> Term0 v +betaReduce (App' (Lam' f) arg) = ABT.bind f arg +betaReduce e = e + +betaNormalForm :: Var v => Term0 v -> Term0 v +betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) +betaNormalForm e = e + +-- x -> f x => f +etaNormalForm :: Ord v => Term0 v -> Term0 v +etaNormalForm tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + where + step (LamNamed' v (App' f (Var' v'))) | v == v' = f + step tm = tm + _ -> tm + +-- x -> f x => f as long as `x` is a variable of type `Var.Eta` +etaReduceEtaVars :: Var v => Term0 v -> Term0 v +etaReduceEtaVars tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + where + ok v v' = v == v' && Var.typeOf v == Var.Eta + step (LamNamed' v (App' f (Var' v'))) | ok v v' = f + step tm = tm + _ -> tm + +-- This converts `Reference`s it finds that are in the input `Map` +-- back to free variables +unhashComponent :: forall v a. Var v + => Map Reference (Term v a) + -> Map Reference (v, Term v a) +unhashComponent m = let + usedVars = foldMap (Set.fromList . ABT.allVars) m + m' :: Map Reference (v, Term v a) + m' = evalState (Map.traverseWithKey assignVar m) usedVars where + assignVar r t = (,t) <$> ABT.freshenS (refNamed r) + unhash1 = ABT.rebuildUp' go where + go e@(Ref' r) = case Map.lookup r m' of + Nothing -> e + Just (v, _) -> var (ABT.annotation e) v + go e = e + in second unhash1 <$> m' + where + -- Variable whose name is derived from the given reference. + refNamed :: Var v => Reference -> v + refNamed ref = Var.named ("ℍ" <> Reference.toText ref) + +hashComponents + :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +hashClosedTerm :: Var v => Term v a -> Reference.Id +hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 + +-- The hash for a constructor +hashConstructor' + :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +hashConstructor' f r cid = + let +-- this is a bit circuitous, but defining everything in terms of hashComponents +-- ensure the hashing is always done in the same way + m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) + in case toList m of + [(r, _)] -> Reference.DerivedId r + _ -> error "unpossible" + +hashConstructor :: Reference -> ConstructorId -> Reference +hashConstructor = hashConstructor' $ constructor () + +hashRequest :: Reference -> ConstructorId -> Reference +hashRequest = hashConstructor' $ request () + +fromReferent :: Ord v + => a + -> Referent + -> Term2 vt at ap v a +fromReferent a = \case + Referent.Ref r -> ref a r + Referent.Con r i ct -> case ct of + CT.Data -> constructor a r i + CT.Effect -> request a r i + +instance Var v => Hashable1 (F v a p) where + hash1 hashCycle hash e + = let (tag, hashed, varint) = + (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) + in + case e of + -- So long as `Reference.Derived` ctors are created using the same + -- hashing function as is used here, this case ensures that references + -- are 'transparent' wrt hash and hashing is unaffected by whether + -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash + -- the same. + Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) + Ref (Reference.Derived h i n) -> Hashable.accumulate + [ tag 1 + , hashed $ Hashable.fromBytes (Hash.toBytes h) + , Hashable.Nat i + , Hashable.Nat n + ] + -- Note: start each layer with leading `1` byte, to avoid collisions + -- with types, which start each layer with leading `0`. + -- See `Hashable1 Type.F` + _ -> + Hashable.accumulate + $ tag 1 + : case e of + Nat i -> [tag 64, accumulateToken i] + Int i -> [tag 65, accumulateToken i] + Float n -> [tag 66, Hashable.Double n] + Boolean b -> [tag 67, accumulateToken b] + Text t -> [tag 68, accumulateToken t] + Char c -> [tag 69, accumulateToken c] + Blank b -> tag 1 : case b of + B.Blank -> [tag 0] + B.Recorded (B.Placeholder _ s) -> + [tag 1, Hashable.Text (Text.pack s)] + B.Recorded (B.Resolve _ s) -> + [tag 2, Hashable.Text (Text.pack s)] + Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] + Ref Reference.Derived {} -> + error "handled above, but GHC can't figure this out" + App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] + Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] + List as -> tag 5 : varint (Sequence.length as) : map + (hashed . hash) + (toList as) + Lam a -> [tag 6, hashed (hash a)] + -- note: we use `hashCycle` to ensure result is independent of + -- let binding order + LetRec _ as a -> case hashCycle as of + (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs + -- here, order is significant, so don't use hashCycle + Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + If b t f -> + [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] + Request r n -> [tag 10, accumulateToken r, varint n] + Constructor r n -> [tag 12, accumulateToken r, varint n] + Match e branches -> + tag 13 : hashed (hash e) : concatMap h branches + where + h (MatchCase pat guard branch) = concat + [ [accumulateToken pat] + , toList (hashed . hash <$> guard) + , [hashed (hash branch)] + ] + Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] + And x y -> [tag 16, hashed $ hash x, hashed $ hash y] + Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] + TermLink r -> [tag 18, accumulateToken r] + TypeLink r -> [tag 19, accumulateToken r] + +-- mostly boring serialization code below ... + +instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec + +instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where + Int x == Int y = x == y + Nat x == Nat y = x == y + Float x == Float y = x == y + Boolean x == Boolean y = x == y + Text x == Text y = x == y + Char x == Char y = x == y + Blank b == Blank q = b == q + Ref x == Ref y = x == y + TermLink x == TermLink y = x == y + TypeLink x == TypeLink y = x == y + Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 + Request r cid == Request r2 cid2 = r == r2 && cid == cid2 + Handle h b == Handle h2 b2 = h == h2 && b == b2 + App f a == App f2 a2 = f == f2 && a == a2 + Ann e t == Ann e2 t2 = e == e2 && t == t2 + List v == List v2 = v == v2 + If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 + And a b == And a2 b2 = a == a2 && b == b2 + Or a b == Or a2 b2 = a == a2 && b == b2 + Lam a == Lam b = a == b + LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 + Let _ binding body == Let _ binding2 body2 = + binding == binding2 && body == body2 + Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 + _ == _ = False + + +instance (Show v, Show a) => Show (F v a0 p a) where + showsPrec = go + where + go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n + go _ (Nat n ) = shows n + go _ (Float n ) = shows n + go _ (Boolean True ) = s "true" + go _ (Boolean False) = s "false" + go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k + go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x + go _ (Lam body ) = showParen True (s "λ " <> shows body) + go _ (List vs ) = showListWith shows (toList vs) + go _ (Blank b ) = case b of + B.Blank -> s "_" + B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) + B.Recorded (B.Resolve _ r) -> s r + go _ (Ref r) = s "Ref(" <> shows r <> s ")" + go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" + go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" + go _ (Let _ b body) = + showParen True (s "let " <> shows b <> s " in " <> shows body) + go _ (LetRec _ bs body) = showParen + True + (s "let rec" <> shows bs <> s " in " <> shows body) + go _ (Handle b body) = showParen + True + (s "handle " <> shows b <> s " in " <> shows body) + go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n + go _ (Match scrutinee cases) = showParen + True + (s "case " <> shows scrutinee <> s " of " <> shows cases) + go _ (Text s ) = shows s + go _ (Char c ) = shows c + go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n + go p (If c t f) = + showParen (p > 0) + $ s "if " + <> shows c + <> s " then " + <> shows t + <> s " else " + <> shows f + go p (And x y) = + showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y + go p (Or x y) = + showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y + (<>) = (.) + s = showString \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Type.hs b/parser-typechecker/src/Unison/Hashing/V1/Type.hs new file mode 100644 index 0000000000..600097118a --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Type.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Type where + +import Unison.Prelude + +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Hashing.V1.Reference (Reference) +import qualified Unison.Hashing.V1.Reference as Reference +import qualified Unison.Hashing.V1.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +-- | Base functor for types in the Unison language +data F a + = Ref Reference + | Arrow a a + | Ann a K.Kind + | App a a + | Effect a a + | Effects [a] + | Forall a + | IntroOuter a -- binder like ∀, used to introduce variables that are + -- bound by outer type signatures, to support scoped type + -- variables + deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) + +instance Eq1 F where (==#) = (==) +instance Ord1 F where compare1 = compare +instance Show1 F where showsPrec1 = showsPrec + +-- | Types are represented as ABTs over the base functor F, with variables in `v` +type Type v a = ABT.Term F v a + +wrapV :: Ord v => Type v a -> Type (ABT.V v) a +wrapV = ABT.vmap ABT.Bound + +freeVars :: Type v a -> Set v +freeVars = ABT.freeVars + +bindExternal + :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a +bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] + +bindNames + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq + +instance (Show v) => Show (Monotype v a) where + show = show . getPolytype + +-- Smart constructor which checks if a `Type` has no `Forall` quantifiers. +monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) +monotype t = Monotype <$> ABT.visit isMono t where + isMono (Forall' _) = Just Nothing + isMono _ = Nothing + +arity :: Type v a -> Int +arity (ForallNamed' _ body) = arity body +arity (Arrow' _ o) = 1 + arity o +arity (Ann' a _) = arity a +arity _ = 0 + +-- some smart patterns +pattern Ref' r <- ABT.Tm' (Ref r) +pattern Arrow' i o <- ABT.Tm' (Arrow i o) +pattern Arrow'' i es o <- Arrow' i (Effect'' es o) +pattern Arrows' spine <- (unArrows -> Just spine) +pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) +pattern Ann' t k <- ABT.Tm' (Ann t k) +pattern App' f x <- ABT.Tm' (App f x) +pattern Apps' f args <- (unApps -> Just (f, args)) +pattern Pure' t <- (unPure -> Just t) +pattern Effects' es <- ABT.Tm' (Effects es) +-- Effect1' must match at least one effect +pattern Effect1' e t <- ABT.Tm' (Effect e t) +pattern Effect' es t <- (unEffects1 -> Just (es, t)) +pattern Effect'' es t <- (unEffect0 -> (es, t)) +-- Effect0' may match zero effects +pattern Effect0' es t <- (unEffect0 -> (es, t)) +pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) +pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) +pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) +pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) +pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst + +unPure :: Ord v => Type v a -> Maybe (Type v a) +unPure (Effect'' [] t) = Just t +unPure (Effect'' _ _) = Nothing +unPure t = Just t + +unArrows :: Type v a -> Maybe [Type v a] +unArrows t = + case go t of [_] -> Nothing; l -> Just l + where go (Arrow' i o) = i : go o + go o = [o] + +unEffectfulArrows + :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) +unEffectfulArrows t = case t of + Arrow' i o -> Just (i, go o) + _ -> Nothing + where + go (Effect1' (Effects' es) (Arrow' i o)) = + (Just $ es >>= flattenEffects, i) : go o + go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] + go (Arrow' i o) = (Nothing, i) : go o + go t = [(Nothing, t)] + +unApps :: Type v a -> Maybe (Type v a, [Type v a]) +unApps t = case go t [] of + [] -> Nothing + [ _ ] -> Nothing + f : args -> Just (f, args) + where + go (App' i o) acc = go i (o : acc) + go fn args = fn : args + +unIntroOuters :: Type v a -> Maybe ([v], Type v a) +unIntroOuters t = go t [] + where go (IntroOuterNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just (reverse vs, body) + +-- Most code doesn't care about `introOuter` binders and is fine dealing with the +-- these outer variable references as free variables. This function strips out +-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. +stripIntroOuters :: Type v a -> Type v a +stripIntroOuters t = case unIntroOuters t of + Just (_, t) -> t + Nothing -> t + +unForalls :: Type v a -> Maybe ([v], Type v a) +unForalls t = go t [] + where go (ForallNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just(reverse vs, body) + +unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) +unEffect0 (Effect1' e a) = (flattenEffects e, a) +unEffect0 t = ([], t) + +unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) +unEffects1 (Effect1' (Effects' es) a) = Just (es, a) +unEffects1 _ = Nothing + +-- | True if the given type is a function, possibly quantified +isArrow :: ABT.Var v => Type v a -> Bool +isArrow (ForallNamed' _ t) = isArrow t +isArrow (Arrow' _ _) = True +isArrow _ = False + +-- some smart constructors + +ref :: Ord v => a -> Reference -> Type v a +ref a = ABT.tm' a . Ref + +refId :: Ord v => a -> Reference.Id -> Type v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Type v a +termLink a = ABT.tm' a . Ref $ termLinkRef + +typeLink :: Ord v => a -> Type v a +typeLink a = ABT.tm' a . Ref $ typeLinkRef + +derivedBase32Hex :: Ord v => Reference -> a -> Type v a +derivedBase32Hex r a = ref a r + +intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference +intRef = Reference.Builtin "Int" +natRef = Reference.Builtin "Nat" +floatRef = Reference.Builtin "Float" +booleanRef = Reference.Builtin "Boolean" +textRef = Reference.Builtin "Text" +charRef = Reference.Builtin "Char" +listRef = Reference.Builtin "Sequence" +bytesRef = Reference.Builtin "Bytes" +effectRef = Reference.Builtin "Effect" +termLinkRef = Reference.Builtin "Link.Term" +typeLinkRef = Reference.Builtin "Link.Type" + +builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference +builtinIORef = Reference.Builtin "IO" +fileHandleRef = Reference.Builtin "Handle" +filePathRef = Reference.Builtin "FilePath" +threadIdRef = Reference.Builtin "ThreadId" +socketRef = Reference.Builtin "Socket" + +mvarRef, tvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +tvarRef = Reference.Builtin "TVar" + +tlsRef :: Reference +tlsRef = Reference.Builtin "Tls" + +stmRef :: Reference +stmRef = Reference.Builtin "STM" + +tlsClientConfigRef :: Reference +tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" + +tlsServerConfigRef :: Reference +tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" + +tlsSignedCertRef :: Reference +tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" + +tlsPrivateKeyRef :: Reference +tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" + +tlsCipherRef :: Reference +tlsCipherRef = Reference.Builtin "Tls.Cipher" + +tlsVersionRef :: Reference +tlsVersionRef = Reference.Builtin "Tls.Version" + +hashAlgorithmRef :: Reference +hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" + +codeRef, valueRef :: Reference +codeRef = Reference.Builtin "Code" +valueRef = Reference.Builtin "Value" + +anyRef :: Reference +anyRef = Reference.Builtin "Any" + +any :: Ord v => a -> Type v a +any a = ref a anyRef + +builtin :: Ord v => a -> Text -> Type v a +builtin a = ref a . Reference.Builtin + +int :: Ord v => a -> Type v a +int a = ref a intRef + +nat :: Ord v => a -> Type v a +nat a = ref a natRef + +float :: Ord v => a -> Type v a +float a = ref a floatRef + +boolean :: Ord v => a -> Type v a +boolean a = ref a booleanRef + +text :: Ord v => a -> Type v a +text a = ref a textRef + +char :: Ord v => a -> Type v a +char a = ref a charRef + +fileHandle :: Ord v => a -> Type v a +fileHandle a = ref a fileHandleRef + +threadId :: Ord v => a -> Type v a +threadId a = ref a threadIdRef + +builtinIO :: Ord v => a -> Type v a +builtinIO a = ref a builtinIORef + +socket :: Ord v => a -> Type v a +socket a = ref a socketRef + +list :: Ord v => a -> Type v a +list a = ref a listRef + +bytes :: Ord v => a -> Type v a +bytes a = ref a bytesRef + +effectType :: Ord v => a -> Type v a +effectType a = ref a $ effectRef + +code, value :: Ord v => a -> Type v a +code a = ref a codeRef +value a = ref a valueRef + +app :: Ord v => a -> Type v a -> Type v a -> Type v a +app a f arg = ABT.tm' a (App f arg) + +-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one +-- meant for `app (f x) y` +apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a +apps = foldl' go where go f (a, t) = app a f t + +app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a +app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg + +apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a +apps' = foldl app' + +arrow :: Ord v => a -> Type v a -> Type v a -> Type v a +arrow a i o = ABT.tm' a (Arrow i o) + +arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a +arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o + +ann :: Ord v => a -> Type v a -> K.Kind -> Type v a +ann a e t = ABT.tm' a (Ann e t) + +forall :: Ord v => a -> v -> Type v a -> Type v a +forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) + +introOuter :: Ord v => a -> v -> Type v a -> Type v a +introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) + +iff :: Var v => Type v () +iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a + where aa = Var.named "a" + a = var () aa + f x = ((), x) + +iff' :: Var v => a -> Type v a +iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +iff2 :: Var v => a -> Type v a +iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +andor :: Ord v => Type v () +andor = arrows (f <$> [boolean(), boolean()]) $ boolean() + where f x = ((), x) + +andor' :: Ord v => a -> Type v a +andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a + where f x = (a, x) + +var :: Ord v => a -> v -> Type v a +var = ABT.annotatedVar + +v' :: Var v => Text -> Type v () +v' s = ABT.var (Var.named s) + +-- Like `v'`, but creates an annotated variable given an annotation +av' :: Var v => a -> Text -> Type v a +av' a s = ABT.annotatedVar a (Var.named s) + +forall' :: Var v => a -> [Text] -> Type v a -> Type v a +forall' a vs body = foldr (forall a) body (Var.named <$> vs) + +foralls :: Ord v => a -> [v] -> Type v a -> Type v a +foralls a vs body = foldr (forall a) body vs + +-- Note: `a -> b -> c` parses as `a -> (b -> c)` +-- the annotation associated with `b` will be the annotation for the `b -> c` +-- node +arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a +arrows ts result = foldr go result ts where + go = uncurry arrow + +-- The types of effectful computations +effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a +effect a es (Effect1' fs t) = + let es' = (es >>= flattenEffects) ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) + +effects :: Ord v => a -> [Type v a] -> Type v a +effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) + +effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a +effect1 a es (Effect1' fs t) = + let es' = flattenEffects es ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect1 a es t = ABT.tm' a (Effect es t) + +flattenEffects :: Type v a -> [Type v a] +flattenEffects (Effects' es) = es >>= flattenEffects +flattenEffects es = [es] + +-- The types of first-class effect values +-- which get deconstructed in effect handlers. +effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a +effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] + +-- Strips effects from a type. E.g. `{e} a` becomes `a`. +stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) +stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) +stripEffect t = ([], t) + +-- The type of the flipped function application operator: +-- `(a -> (a -> b) -> b)` +flipApply :: Var v => Type v () -> Type v () +flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) + where b = ABT.fresh t (Var.named "b") + +generalize' :: Var v => Var.Type -> Type v a -> Type v a +generalize' k t = generalize vsk t where + vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] + +-- | Bind the given variables with an outer `forall`, if they are used in `t`. +generalize :: Ord v => [v] -> Type v a -> Type v a +generalize vs t = foldr f t vs + where + f v t = + if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + +unforall :: Type v a -> Type v a +unforall (ForallsNamed' _ t) = t +unforall t = t + +unforall' :: Type v a -> ([v], Type v a) +unforall' (ForallsNamed' vs t) = (vs, t) +unforall' t = ([], t) + +dependencies :: Ord v => Type v a -> Set Reference +dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t + where f t@(Ref r) = Writer.tell [r] $> t + f t = pure t + +updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a +updateDependencies typeUpdates = ABT.rebuildUp go + where + go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) + go f = f + +usesEffects :: Ord v => Type v a -> Bool +usesEffects t = getAny . getConst $ ABT.visit go t where + go (Effect1' _ _) = Just (Const (Any True)) + go _ = Nothing + +-- Returns free effect variables in the given type, for instance, in: +-- +-- ∀ e3 . a ->{e,e2} b ->{e3} c +-- +-- This function would return the set {e, e2}, but not `e3` since `e3` +-- is bound by the enclosing forall. +freeEffectVars :: Ord v => Type v a -> Set v +freeEffectVars t = + Set.fromList . join . runIdentity $ + ABT.foreachSubterm go (snd <$> ABT.annotateBound t) + where + go t@(Effects' es) = + let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go t@(Effect1' e _) = + let frees = Set.fromList [ v | Var' v <- flattenEffects e ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go _ = pure [] + +-- Converts all unadorned arrows in a type to have fresh +-- existential ability requirements. For example: +-- +-- (a -> b) -> [a] -> [b] +-- +-- Becomes +-- +-- (a ->{e1} b) ->{e2} [a] ->{e3} [b] +existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) +existentializeArrows newVar t = ABT.visit go t + where + go t@(Arrow' a b) = case b of + -- If an arrow already has attached abilities, + -- leave it alone. Ex: `a ->{e} b` is kept as is. + Effect1' _ _ -> Just $ do + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + pure $ arrow (ABT.annotation t) a b + -- For unadorned arrows, make up a fresh variable. + -- So `a -> b` becomes `a ->{e} b`, using the + -- `newVar` variable generator. + _ -> Just $ do + e <- newVar + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + let ann = ABT.annotation t + pure $ arrow ann a (effect ann [var ann e] b) + go _ = Nothing + +purifyArrows :: (Ord v) => Type v a -> Type v a +purifyArrows = ABT.visitPure go + where + go t@(Arrow' a b) = case b of + Effect1' _ _ -> Nothing + _ -> Just $ arrow ann a (effect ann [] b) + where ann = ABT.annotation t + go _ = Nothing + +-- Remove free effect variables from the type that are in the set +removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a +removeEffectVars removals t = + let z = effects () [] + t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t + -- leave explicitly empty `{}` alone + removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) + removeEmpty t@(Effect1' e v) = + case flattenEffects e of + [] -> Just (ABT.visitPure removeEmpty v) + es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) + removeEmpty t@(Effects' es) = + Just $ effects (ABT.annotation t) (es >>= flattenEffects) + removeEmpty _ = Nothing + in ABT.visitPure removeEmpty t' + +-- Remove all effect variables from the type. +-- Used for type-based search, we apply this transformation to both the +-- indexed type and the query type, so the user can supply `a -> b` that will +-- match `a ->{e} b` (but not `a ->{IO} b`). +removeAllEffectVars :: ABT.Var v => Type v a -> Type v a +removeAllEffectVars t = let + allEffectVars = foldMap go (ABT.subterms t) + go (Effects' vs) = Set.fromList [ v | Var' v <- vs] + go (Effect1' (Var' v) _) = Set.singleton v + go _ = mempty + (vs, tu) = unforall' t + in generalize vs (removeEffectVars allEffectVars tu) + +removePureEffects :: ABT.Var v => Type v a -> Type v a +removePureEffects t | not Settings.removePureEffects = t + | otherwise = + generalize vs $ removeEffectVars (Set.filter isPure fvs) tu + where + (vs, tu) = unforall' t + fvs = freeEffectVars tu `Set.difference` ABT.freeVars t + -- If an effect variable is mentioned only once, it is on + -- an arrow `a ->{e} b`. Generalizing this to + -- `∀ e . a ->{e} b` gives us the pure arrow `a -> b`. + isPure v = ABT.occurrences v tu <= 1 + +editFunctionResult + :: forall v a + . Ord v + => (Type v a -> Type v a) + -> Type v a + -> Type v a +editFunctionResult f = go + where + go :: Type v a -> Type v a + go (ABT.Term s a t) = case t of + ABT.Tm (Forall t) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t + ABT.Tm (Arrow i o) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o + ABT.Abs v r -> + (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r + _ -> f (ABT.Term s a t) + +functionResult :: Type v a -> Maybe (Type v a) +functionResult = go False + where + go inArr (ForallNamed' _ body) = go inArr body + go _inArr (Arrow' _i o ) = go True o + go inArr t = if inArr then Just t else Nothing + + +-- | Bind all free variables (not in `except`) that start with a lowercase +-- letter and are unqualified with an outer `forall`. +-- `a -> a` becomes `∀ a . a -> a` +-- `B -> B` becomes `B -> B` (not changed) +-- `.foo -> .foo` becomes `.foo -> .foo` (not changed) +-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) +generalizeLowercase :: Var v => Set v -> Type v a -> Type v a +generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars + where + vars = + [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] + +-- Convert all free variables in `allowed` to variables bound by an `introOuter`. +freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a +freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars + where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed + +-- | This function removes all variable shadowing from the types and reduces +-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing +-- two different types. +cleanupVars :: Var v => [Type v a] -> [Type v a] +cleanupVars ts | not Settings.cleanupTypes = ts +cleanupVars ts = let + changedVars = cleanupVarsMap ts + in cleanupVars1' changedVars <$> ts + +-- Compute a variable replacement map from a collection of types, which +-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids +-- for multiple related types, like when reporting a type error. +cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v +cleanupVarsMap ts = let + varsByName = foldl' step Map.empty (ts >>= ABT.allVars) + step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m + changedVars = Map.fromList [ (v, Var.freshenId i v) + | (_, vs) <- Map.toList varsByName + , (v,i) <- nubOrd vs `zip` [0..]] + in changedVars + +cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a +cleanupVars1' = ABT.changeVars + +-- | This function removes all variable shadowing from the type and reduces +-- fresh ids to the minimum possible to avoid ambiguity. +cleanupVars1 :: Var v => Type v a -> Type v a +cleanupVars1 t | not Settings.cleanupTypes = t +cleanupVars1 t = let [t'] = cleanupVars [t] in t' + +-- This removes duplicates and normalizes the order of ability lists +cleanupAbilityLists :: Var v => Type v a -> Type v a +cleanupAbilityLists = ABT.visitPure go + where + -- leave explicitly empty `{}` alone + go (Effect1' (Effects' []) _v) = Nothing + go t@(Effect1' e v) = + let es = Set.toList . Set.fromList $ flattenEffects e + in case es of + [] -> Just (ABT.visitPure go v) + _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) + go _ = Nothing + +cleanups :: Var v => [Type v a] -> [Type v a] +cleanups ts = cleanupVars $ map cleanupAbilityLists ts + +cleanup :: Var v => Type v a -> Type v a +cleanup t | not Settings.cleanupTypes = t +cleanup t = cleanupVars1 . cleanupAbilityLists $ t + +toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference (Ref' r) = r +-- a bit of normalization - any unused type parameters aren't part of the hash +toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +toReference t = Reference.Derived (ABT.hash t) 0 1 + +toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions ty = + let (vs, _) = unforall' ty + gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty + in Set.fromList $ toReference . gen <$> ABT.subterms ty + +hashComponents + :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +instance Hashable1 F where + hash1 hashCycle hash e = + let + (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `0` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 0 : case e of + Ref r -> [tag 0, Hashable.accumulateToken r] + Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] + App a b -> [tag 2, hashed (hash a), hashed (hash b) ] + Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] + -- Example: + -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as + -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from + -- c) {Remote, Abort} (() -> {Abort} ()) + Effects es -> let + (hs, _) = hashCycle es + in tag 4 : map hashed hs + Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] + Forall a -> [tag 6, hashed (hash a)] + IntroOuter a -> [tag 7, hashed (hash a)] + +instance Show a => Show (F a) where + showsPrec = go where + go _ (Ref r) = shows r + go p (Arrow i o) = + showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o + go p (Ann t k) = + showParen (p > 1) $ shows t <> s":" <> shows k + go p (App f x) = + showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x + go p (Effects es) = showParen (p > 0) $ + s"{" <> shows es <> s"}" + go p (Effect e t) = showParen (p > 0) $ + showParen True $ shows e <> s" " <> showsPrec p t + go p (Forall body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"∀ " <> shows body + go p (IntroOuter body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"outer " <> shows body + (<>) = (.) + s = showString diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index dbda3fa42e..17d4527378 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -92,6 +92,14 @@ library Unison.DeclPrinter Unison.FileParser Unison.FileParsers + Unison.Hashing.V1.DataDeclaration + Unison.Hashing.V1.LabeledDependency + Unison.Hashing.V1.Pattern + Unison.Hashing.V1.Reference + Unison.Hashing.V1.Reference.Util + Unison.Hashing.V1.Referent + Unison.Hashing.V1.Term + Unison.Hashing.V1.Type Unison.Lexer Unison.Lexer.Pos Unison.NamePrinter From 86ed86872a887e23a1895102a342777105e8ab7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Thu, 9 Sep 2021 09:13:43 -0400 Subject: [PATCH 060/148] Update welcome message with ui command MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Revamp the welcome message somewhat by including a small "get started" section that displays hints about the `help` command, the `ui` command and links to docs and Unison Share before finally telling the user about the files being watched. Example: ``` Now starting the Unison Codebase Manager (UCM)... _____ _ | | |___|_|___ ___ ___ | | | | |_ -| . | | |_____|_|_|_|___|___|_|_| 👋 Welcome to Unison! You are running version: latest-370-g63bc75ea3' (built on 2021-09-07) Get started: 📖 Type help to get help 🎨 Type ui to open the Codebase UI in your default browser 📚 Read the official docs at https://unisonweb.org/docs 🌎 Visit Unison Share at https://share.unison-lang.org to discover libraries 👀 I'm watching for changes to .u files under ~/code/unison/unison ``` --- .../src/Unison/CommandLine/Main.hs | 23 ++++++++++++------- parser-typechecker/unison/Main.hs | 14 +++++++---- 2 files changed, 24 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index bfb5dda69a..f6ba32d6cf 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -135,14 +135,21 @@ welcomeMessage dir version = <> P.newline <> P.newline <> P.linesSpaced - [ P.wrap "Welcome to Unison!" - , P.wrap ("You are running version: " <> P.string version) - , P.wrap - ( "I'm currently watching for changes to .u files under " - <> (P.group . P.blue $ fromString dir) - ) - , P.wrap ("Type " <> P.hiBlue "help" <> " to get help. 😎") - ] + [ P.wrap "👋 Welcome to Unison!", + P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline, + P.wrap "Get started:", + P.indentN + 2 + ( P.column2 + [ ("📖", "Type " <> P.hiBlue "help" <> " to get help"), + ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), + ("📚", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), + ("🌎", "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), + ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ fromString dir)) + ] + ) + ] + hintFreshCodebase :: ReadRemoteNamespace -> P.Pretty P.ColorText hintFreshCodebase ns = diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 56002fb258..b82330b199 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -110,12 +110,16 @@ main = do (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do - PT.putPrettyLn $ P.lines - ["The Unison Codebase UI is running at", P.string $ Server.urlFor Server.UI baseUrl] case isHeadless of Headless -> do - PT.putPrettyLn $ P.lines - ["I've started the codebase API server at" , P.string $ Server.urlFor Server.Api baseUrl] + PT.putPrettyLn $ + P.lines + [ "I've started the Codebase API server at", + P.string $ Server.urlFor Server.Api baseUrl, + "and the Codebase UI at", + P.string $ Server.urlFor Server.UI baseUrl + ] + PT.putPrettyLn $ P.string "Running the codebase manager headless with " <> P.shown GHC.Conc.numCapabilities <> " " @@ -124,7 +128,7 @@ main = do mvar <- newEmptyMVar takeMVar mvar WithCLI -> do - PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager..." + PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." launch currentDir config runtime theCodebase [] (Just baseUrl) closeCodebase From 63cde3a4858d8b2063e445c336c325b06dbc6cfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 9 Sep 2021 11:02:24 -0400 Subject: [PATCH 061/148] Change precedence of list patterns --- parser-typechecker/src/Unison/TermPrinter.hs | 6 +- unison-src/transcripts-round-trip/main.md | 29 ++++++ .../transcripts-round-trip/main.output.md | 93 +++++++++++++++++-- 3 files changed, 118 insertions(+), 10 deletions(-) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 172dfa7282..1687a7083d 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -493,9 +493,9 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of (pr, rvs) = prettyPattern n c (p + 1) lvs r f i s = (paren (p >= i) (pl <> " " <> (fmt (S.Op op) s) <> " " <> pr), rvs) in case op of - Pattern.Cons -> f 9 "+:" - Pattern.Snoc -> f 9 ":+" - Pattern.Concat -> f 9 "++" + Pattern.Cons -> f 0 "+:" + Pattern.Snoc -> f 0 ":+" + Pattern.Concat -> f 0 "++" where l :: IsString s => String -> s l = fromString diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 42930a80cb..9aa2fec640 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -79,3 +79,32 @@ f x = let .> load scratch.u ``` +## Parens around infix patterns + +Regression test for https://github.com/unisonweb/unison/issues/2224 + +```unison:hide +f : [a] -> a +f xs = match xs with + x +: (x' +: rest) -> x + +g : [a] -> a +g xs = match xs with + (rest :+ x') :+ x -> x + +h : [[a]] -> a +h xs = match xs with + (rest :+ (rest' :+ x)) -> x +``` + +```ucm +.> add +.> edit f g +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 53e3132845..ddef0a9fe5 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -157,7 +157,6 @@ unique type Blah = Blah Boolean Boolean f : Blah -> Boolean f x = let - 0 (Blah.Blah a b) = x a ``` @@ -181,11 +180,7 @@ f x = let = Blah Boolean Boolean f : Blah -> Boolean - f x = - 0 - let - (Blah a b) = x - a + f = cases Blah a b -> a You can edit them there, then do `update` to replace the definitions currently in this namespace. @@ -203,7 +198,7 @@ f x = let its history to that of the specified namespace. - 1. #53gruvtk78 : add + 1. #clsum27pr1 : add 2. #pqvd5behc2 : reset-root #pqvd5behc2 3. #dbvse9969b : add 4. #pqvd5behc2 : reset-root #pqvd5behc2 @@ -229,3 +224,87 @@ f x = let f : Blah -> Boolean ``` +## Parens around infix patterns + +Regression test for https://github.com/unisonweb/unison/issues/2224 + +```unison +f : [a] -> a +f xs = match xs with + x +: (x' +: rest) -> x + +g : [a] -> a +g xs = match xs with + (rest :+ x') :+ x -> x + +h : [[a]] -> a +h xs = match xs with + (rest :+ (rest' :+ x)) -> x +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + f : [a] -> a + g : [a] -> a + h : [[a]] -> a + +.> edit f g + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + f : [a] -> a + f = cases x +: (x' +: rest) -> x + + g : [a] -> a + g = cases rest :+ x' :+ x -> x + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #acngtb04a8 : add + 2. #pqvd5behc2 : reset-root #pqvd5behc2 + 3. #clsum27pr1 : add + 4. #pqvd5behc2 : reset-root #pqvd5behc2 + 5. #dbvse9969b : add + 6. #pqvd5behc2 : reset-root #pqvd5behc2 + 7. #8rn1an5gj8 : add + 8. #pqvd5behc2 : builtins.mergeio + 9. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + f : [a] -> a + g : [a] -> a + +``` From a65bc67661856f2e970f715a1443dac659fb4c27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Thu, 9 Sep 2021 12:49:09 -0400 Subject: [PATCH 062/148] Randomize the view of Earth in the welcome message When the welcome message is compiled, pick a random face of the Earth. Also improve the `help` part of the message slightly. --- .../src/Unison/CommandLine/Main.hs | 51 ++++++++++--------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index f6ba32d6cf..c264bd89c2 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -36,6 +36,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO import qualified System.Console.Haskeline as Line import qualified Crypto.Random as Random +import System.Random (randomRIO) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Runtime as Runtime import qualified Unison.Codebase as Codebase @@ -129,27 +130,29 @@ asciiartUnison = <> P.cyan "|___|" <> P.purple "_|_|" -welcomeMessage :: FilePath -> String -> P.Pretty P.ColorText -welcomeMessage dir version = - asciiartUnison - <> P.newline - <> P.newline - <> P.linesSpaced - [ P.wrap "👋 Welcome to Unison!", - P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline, - P.wrap "Get started:", - P.indentN - 2 - ( P.column2 - [ ("📖", "Type " <> P.hiBlue "help" <> " to get help"), - ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), - ("📚", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), - ("🌎", "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), - ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ fromString dir)) - ] - ) - ] +welcomeMessage :: FilePath -> String -> IO (P.Pretty P.ColorText) +welcomeMessage dir version = do + earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2) + pure $ + asciiartUnison + <> P.newline + <> P.newline + <> P.linesSpaced + [ P.wrap "👋 Welcome to Unison!", + P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline, + P.wrap "Get started:", + P.indentN + 2 + ( P.column2 + [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help " <> " to view help for one command"), + ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), + ("📚", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), + (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), + ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ fromString dir)) + ] + ) + ] hintFreshCodebase :: ReadRemoteNamespace -> P.Pretty P.ColorText hintFreshCodebase ns = @@ -172,10 +175,12 @@ main main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do dir' <- shortenDirectory dir root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - putPrettyLn $ case defaultBaseLib of + welcome <- welcomeMessage dir' version + putPrettyLn $ + case defaultBaseLib of Just ns | Branch.isOne root -> - welcomeMessage dir' version <> P.newline <> P.newline <> hintFreshCodebase ns - _ -> welcomeMessage dir' version + welcome <> P.newline <> P.newline <> hintFreshCodebase ns + _ -> welcome eventQueue <- Q.newIO do -- we watch for root branch tip changes, but want to ignore ones we expect. From 51dfa623ee9677ef56e9e9153656266aef75af55 Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 9 Sep 2021 10:59:57 -0700 Subject: [PATCH 063/148] initial working base pull --- parser-typechecker/src/Unison/Codebase.hs | 2 +- .../src/Unison/Codebase/Editor/Command.hs | 2 +- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 2 +- .../Unison/Codebase/Editor/VersionParser.hs | 8 ++--- .../src/Unison/CommandLine/Main.hs | 31 +++++++++++++++---- 5 files changed, 32 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index bf3f05022c..6d7454c773 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -212,7 +212,7 @@ isType c r = case r of -- | Sync elements as needed from a remote codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; -- otherwise we try to load the root branch. -importRemoteBranch :: +importRemoteBranch :: -- RLM Note: Maybe here forall m v a. MonadIO m => Codebase m v a -> diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index dc3889a687..fc34c1c74a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -186,7 +186,7 @@ data Command m i v a where -- we want to import as little as possible, so we pass the SBH/path as part -- of the `RemoteNamespace`. The Branch that's returned should be fully -- imported and not retain any resources from the remote codebase - ImportRemoteBranch :: + ImportRemoteBranch :: -- RLM Notes: here for bringing remote into repo ReadRemoteNamespace -> SyncMode -> Command m i v (Either GitError (Branch m)) -- Syncs the Branch to some codebase and updates the head to the head of this causal. diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 146a97736e..99cebbeec5 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -36,5 +36,5 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) +type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) type WriteRemotePath = (WriteRepo, Path) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs b/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs index 0ac0a7d473..4f4bf48720 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/VersionParser.hs @@ -12,12 +12,12 @@ import qualified Unison.Codebase.Path as Path import Data.Void (Void) -- |"release/M1j.2" -> "releases._M1j" --- "devel/*" -> "trunk" +-- "latest-*" -> "trunk" defaultBaseLib :: Parsec Void Text ReadRemoteNamespace -defaultBaseLib = fmap makeNS $ devel <|> release +defaultBaseLib = fmap makeNS $ latest <|> release where - devel, release, version :: Parsec Void Text Text - devel = "devel/" *> many anyChar *> eof $> "trunk" + latest, release, version :: Parsec Void Text Text + latest = "latest-" *> many anyChar *> eof $> "trunk" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = fmap Text.pack $ try (someTill anyChar "." <* many anyChar) <|> many anyChar diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index bfb5dda69a..fe82d5dc3d 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -20,6 +20,8 @@ import Unison.Codebase.Editor.Input (Input (..), Event) import qualified Unison.Server.CodebaseServer as Server import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand +import qualified Unison.Codebase.SyncMode as SyncMode +import Data.Sequence (singleton) import Unison.Codebase.Editor.Command (LoadSourceResult(..)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, printNamespace) import Unison.Codebase (Codebase) @@ -45,6 +47,8 @@ import qualified Unison.Util.TQueue as Q import Text.Regex.TDFA import Control.Lens (view) import Control.Error (rightMay) +import Unison.NameSegment (NameSegment(NameSegment)) + -- Expand a numeric argument like `1` or a range like `3-9` expandNumber :: [String] -> String -> [String] @@ -151,6 +155,19 @@ hintFreshCodebase ns = ("pull " <> P.text (uncurry3 printNamespace ns) <> " .base") <> "to set up the default base library. 🏗" +-- RLM Note: Includes downloading base, and eventually, author/licence setup +freshCodebaseSetup :: FilePath -> String -> ReadRemoteNamespace -> IO Input +freshCodebaseSetup dir' version ns = do + let seg = NameSegment "base" + let rootPath = Path.Path { Path.toSeq = singleton seg } + let abs = Path.Absolute {Path.unabsolute = rootPath} + putPrettyLn $ welcomeMessage dir' version <> P.newline <> P.newline <> hintFreshCodebase ns + -- RLM Note: frantic debugging + putPrettyLn $ fromString dir' + putPrettyLn $ P.string version + pure (PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete) -- todo add version and such +-- RLM Note: These inputs and events can be used Input has a PullRemoteBranchI data constructor + main :: FilePath -> Maybe ReadRemoteNamespace @@ -163,18 +180,20 @@ main -> Maybe Server.BaseUrl -> IO () main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do - dir' <- shortenDirectory dir + dir' <- shortenDirectory dir root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - putPrettyLn $ case defaultBaseLib of - Just ns | Branch.isOne root -> - welcomeMessage dir' version <> P.newline <> P.newline <> hintFreshCodebase ns - _ -> welcomeMessage dir' version + testCB <- case defaultBaseLib of + Just ns@(_, _, path) | Branch.isOne root -> do + putPrettyLn $ P.wrap "Downloading base: " <> P.string (show path) + freshCodebaseSetup dir' version ns <&> \cb -> [Right cb] + -- _ -> welcomeMessage dir' version + _ -> do pure [] --RLM Note: temp eventQueue <- Q.newIO do -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef initialInputs + initialInputsRef <- newIORef (testCB ++ initialInputs) -- RLM Notes: hacky shortcut would be to append hand-rolled input here? numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir From 65dec27bbd11e6c2e82a347c73efd3a2ddbe31da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 9 Sep 2021 14:00:13 -0400 Subject: [PATCH 064/148] Add parens around effectful arrow special case. --- parser-typechecker/src/Unison/TypePrinter.hs | 5 +- unison-src/transcripts-round-trip/main.md | 22 +++++ .../transcripts-round-trip/main.output.md | 83 +++++++++++++++++++ 3 files changed, 108 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index 21699fc493..a3c4c16454 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -104,8 +104,9 @@ prettyRaw n im p tp = go n im p tp in (fmt S.TypeOperator "∀ " <> vformatted <> fmt S.TypeOperator ".") `PP.hang` go n im (-1) body t@(Arrow' _ _) -> case t of - EffectfulArrows' (Ref' DD.UnitRef) rest -> arrows True True rest - EffectfulArrows' fst rest -> + EffectfulArrows' (Ref' DD.UnitRef) rest -> + PP.parenthesizeIf (p >= 0) $ arrows True True rest + EffectfulArrows' fst rest -> PP.parenthesizeIf (p >= 0) $ case fst of Var' v | Var.name v == "()" -> fmt S.DelayForceChar "'" <> arrows False True rest diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 9aa2fec640..cb4201f918 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -108,3 +108,25 @@ h xs = match xs with .> load scratch.u ``` +## Type application inserts necessary parens + +Regression test for https://github.com/unisonweb/unison/issues/2392 + +```unison:hide +unique ability Zonk where zonk : Nat +unique type Foo x y = + +foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat +foo n _ = n +``` + +```ucm +.> add +.> edit foo Zonk Foo +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index ddef0a9fe5..6e78c69a88 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -308,3 +308,86 @@ h xs = match xs with g : [a] -> a ``` +## Type application inserts necessary parens + +Regression test for https://github.com/unisonweb/unison/issues/2392 + +```unison +unique ability Zonk where zonk : Nat +unique type Foo x y = + +foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat +foo n _ = n +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Foo x y + unique ability Zonk + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + +.> edit foo Zonk Foo + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + unique type Foo x y + = + + unique ability Zonk where zonk : {Zonk} Nat + + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + foo n _ = n + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #j32i1remee : add + 2. #pqvd5behc2 : reset-root #pqvd5behc2 + 3. #acngtb04a8 : add + 4. #pqvd5behc2 : reset-root #pqvd5behc2 + 5. #clsum27pr1 : add + 6. #pqvd5behc2 : reset-root #pqvd5behc2 + 7. #dbvse9969b : add + 8. #pqvd5behc2 : reset-root #pqvd5behc2 + 9. #8rn1an5gj8 : add + 10. #pqvd5behc2 : builtins.mergeio + 11. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + unique type Foo x y + unique ability Zonk + foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat + +``` From 9791929e99c935dbc640e2c255a9841dbff69bdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 9 Sep 2021 15:24:16 -0400 Subject: [PATCH 065/148] Too eagerly applying parens --- parser-typechecker/src/Unison/TypePrinter.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index a3c4c16454..cb853d16bf 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -105,11 +105,12 @@ prettyRaw n im p tp = go n im p tp `PP.hang` go n im (-1) body t@(Arrow' _ _) -> case t of EffectfulArrows' (Ref' DD.UnitRef) rest -> - PP.parenthesizeIf (p >= 0) $ arrows True True rest - EffectfulArrows' fst rest -> PP.parenthesizeIf (p >= 0) $ + PP.parenthesizeIf (p >= 10) $ arrows True True rest + EffectfulArrows' fst rest -> case fst of - Var' v | Var.name v == "()" - -> fmt S.DelayForceChar "'" <> arrows False True rest + Var' v | Var.name v == "()" -> + PP.parenthesizeIf (p >= 10) $ + fmt S.DelayForceChar "'" <> arrows False True rest _ -> PP.parenthesizeIf (p >= 0) $ go n im 0 fst <> arrows False False rest _ -> "error" From 22f07823d0d3d68230fa003af64e2aeefd674171 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 9 Sep 2021 15:28:40 -0400 Subject: [PATCH 066/148] Hashing.V1.Convert.hashDecls --- .../src/Unison/Builtin/Decls.hs | 10 +- .../src/Unison/Codebase/Editor/AuthorInfo.hs | 6 +- .../src/Unison/Hashing/V1/Convert.hs | 116 +++++++++++ .../src/Unison/Hashing/V1/DataDeclaration.hs | 159 ++++++++++----- .../src/Unison/Hashing/V1/Pattern.hs | 4 +- .../src/Unison/Hashing/V1/Type.hs | 13 ++ .../unison-parser-typechecker.cabal | 1 + unison-core/src/Unison/DataDeclaration.hs | 132 ++++++------ unison-core/src/Unison/Term.hs | 188 +++++++++--------- unison-core/src/Unison/Type.hs | 80 ++++---- 10 files changed, 453 insertions(+), 256 deletions(-) create mode 100644 parser-typechecker/src/Unison/Hashing/V1/Convert.hs diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index 941375a282..608e26b64b 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -4,7 +4,7 @@ module Unison.Builtin.Decls where -import Control.Lens (_3,over) +import Control.Lens (over, _3) import Data.List (elemIndex, find) import qualified Data.Map as Map import Data.Text (Text, unpack) @@ -13,13 +13,13 @@ import qualified Unison.ConstructorType as CT import Unison.DataDeclaration ( DataDeclaration (..), Modifier (Structural, Unique), - hashDecls, ) import qualified Unison.DataDeclaration as DD +import Unison.Hashing.V1.Convert (hashDecls) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import Unison.Referent (Referent, ConstructorId) +import Unison.Referent (ConstructorId, Referent) import qualified Unison.Referent as Referent import Unison.Symbol (Symbol) import Unison.Term (Term, Term2) @@ -117,10 +117,10 @@ failConstructorReferent = Referent.Con testResultRef failConstructorId CT.Data builtinDataDecls :: Var v => [(v, Reference.Id, DataDeclaration v ())] builtinDataDecls = rs1 ++ rs where - rs1 = case hashDecls $ Map.fromList + rs1 = case hashDecls (const $ Just 1) $ Map.fromList [ (v "Link" , link) ] of Right a -> a; Left e -> error $ "builtinDataDecls: " <> show e - rs = case hashDecls $ Map.fromList + rs = case hashDecls (const $ Just 1) $ Map.fromList [ (v "Unit" , unit) , (v "Tuple" , tuple) , (v "Optional" , opt) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs index de6cb47d6f..079bf14a95 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs @@ -2,8 +2,8 @@ module Unison.Codebase.Editor.AuthorInfo where -import Unison.Term (Term, hashComponents) - +import Unison.Term (Term) +import Unison.Hashing.V1.Convert (hashTermComponents) import qualified Unison.Reference as Reference import Unison.Prelude (MonadIO, Word8) import Unison.Var (Var) @@ -49,7 +49,7 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32) (guidRef, guidTerm, guidType) (authorRef, authorTerm, authorType) (chRef, chTerm, chType) - hashAndWrangle v tm = toList . hashComponents $ Map.fromList [(Var.named v, tm)] + hashAndWrangle v tm = toList . hashTermComponents (const $ Just 1) $ Map.fromList [(Var.named v, tm)] (chType, chTypeRef) = (Type.ref a chTypeRef, unsafeParse copyrightHolderHash) (authorType, authorTypeRef) = (Type.ref a authorTypeRef, unsafeParse authorHash) (guidType, guidTypeRef) = (Type.ref a guidTypeRef, unsafeParse guidHash) diff --git a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs new file mode 100644 index 0000000000..d3a98e93d4 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V1.Convert where + +import Control.Lens (over, _3) +import qualified Control.Lens as Lens +import Control.Monad.Validate (Validate) +import qualified Control.Monad.Validate as Validate +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Unison.ABT as ABT +import qualified Unison.DataDeclaration as Memory.DD +import Unison.Hash (Hash) +import qualified Unison.Hashing.V1.DataDeclaration as Hashing.DD +import qualified Unison.Hashing.V1.Reference as Hashing.Reference +import qualified Unison.Hashing.V1.Type as Hashing.Type +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Reference as Memory.Reference +import qualified Unison.Referent as Memory.Referent +import qualified Unison.Type as Memory.Type +import Unison.Var (Var) + +data ResolutionFailure v a + = TermResolutionFailure v a (Set Memory.Referent.Referent) + | TypeResolutionFailure v a (Set Memory.Reference.Reference) + | CycleResolutionFailure Hash + deriving (Eq, Ord, Show) + +type ResolutionResult v a r = Validate (Seq (ResolutionFailure v a)) r + +convertResolutionResult :: Names.ResolutionResult v a r -> ResolutionResult v a r +convertResolutionResult = \case + Left e -> Validate.refute (fmap f e) + Right a -> pure a + where + f = \case + Names.TermResolutionFailure v a rs -> TermResolutionFailure v a rs + Names.TypeResolutionFailure v a rs -> TypeResolutionFailure v a rs + +hashDecls :: + (Eq v, Var v) => + (Hash -> Maybe Hashing.Reference.Size) -> + Map v (Memory.DD.DataDeclaration v a) -> + ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] +hashDecls f memDecls = do + hashingDecls <- traverse m2hDecl memDecls + hashingResult <- convertResolutionResult $ Hashing.DD.hashDecls hashingDecls + pure $ map h2mDeclResult hashingResult + where + lookupHash :: Hash -> ResolutionResult v a Hashing.Reference.Size + lookupHash h = case f h of + Just size -> pure size + Nothing -> Validate.refute . pure $ CycleResolutionFailure h + + m2hDecl :: Ord v => Memory.DD.DataDeclaration v a -> ResolutionResult v a (Hashing.DD.DataDeclaration v a) + m2hDecl (Memory.DD.DataDeclaration mod ann bound ctors) = + Hashing.DD.DataDeclaration (m2hModifier mod) ann bound + <$> traverse (Lens.mapMOf _3 m2hType) ctors + + m2hType :: Ord v => Memory.Type.Type v a -> ResolutionResult v a (Hashing.Type.Type v a) + m2hType = ABT.transformM \case + Memory.Type.Ref ref -> Hashing.Type.Ref <$> m2hReference ref + Memory.Type.Arrow a1 a1' -> pure $ Hashing.Type.Arrow a1 a1' + Memory.Type.Ann a1 ki -> pure $ Hashing.Type.Ann a1 ki + Memory.Type.App a1 a1' -> pure $ Hashing.Type.App a1 a1' + Memory.Type.Effect a1 a1' -> pure $ Hashing.Type.Effect a1 a1' + Memory.Type.Effects a1s -> pure $ Hashing.Type.Effects a1s + Memory.Type.Forall a1 -> pure $ Hashing.Type.Forall a1 + Memory.Type.IntroOuter a1 -> pure $ Hashing.Type.IntroOuter a1 + + m2hReference :: Memory.Reference.Reference -> ResolutionResult v a (Hashing.Reference.Reference) + m2hReference = \case + Memory.Reference.Builtin t -> pure $ Hashing.Reference.Builtin t + Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId <$> m2hReferenceId d + + m2hReferenceId :: Memory.Reference.Id -> ResolutionResult v a (Hashing.Reference.Id) + m2hReferenceId (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i <$> lookupHash h + +h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier +h2mModifier = \case + Hashing.DD.Structural -> Memory.DD.Structural + Hashing.DD.Unique text -> Memory.DD.Unique text + +m2hModifier :: Memory.DD.Modifier -> Hashing.DD.Modifier +m2hModifier = \case + Memory.DD.Structural -> Hashing.DD.Structural + Memory.DD.Unique text -> Hashing.DD.Unique text + +h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) +h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) + +h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a +h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = + Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) + +h2mType :: Ord v => Hashing.Type.Type v a -> Memory.Type.Type v a +h2mType = ABT.transform \case + Hashing.Type.Ref ref -> Memory.Type.Ref (h2mReference ref) + Hashing.Type.Arrow a1 a1' -> Memory.Type.Arrow a1 a1' + Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 ki + Hashing.Type.App a1 a1' -> Memory.Type.App a1 a1' + Hashing.Type.Effect a1 a1' -> Memory.Type.Effect a1 a1' + Hashing.Type.Effects a1s -> Memory.Type.Effects a1s + Hashing.Type.Forall a1 -> Memory.Type.Forall a1 + Hashing.Type.IntroOuter a1 -> Memory.Type.IntroOuter a1 + +h2mReference :: Hashing.Reference.Reference -> Memory.Reference.Reference +h2mReference = \case + Hashing.Reference.Builtin t -> Memory.Reference.Builtin t + Hashing.Reference.DerivedId d -> Memory.Reference.DerivedId (h2mReferenceId d) + +h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id +h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n + + diff --git a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs index 7344274ae5..78d268f11b 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs @@ -1,45 +1,55 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveAnyClass #-} -{-# Language DeriveFoldable #-} -{-# Language DeriveTraversable #-} -{-# Language OverloadedStrings #-} -{-# Language PatternSynonyms #-} -{-# Language ViewPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Unison.Hashing.V1.DataDeclaration ( DataDeclaration (..), EffectDeclaration (..), Decl, - Modifier(..), + Modifier (..), asDataDecl, constructorType, constructorTypes, - declConstructorReferents, + -- declConstructorReferents, declDependencies, dependencies, + bindReferences, + hashDecls, ) where -import Unison.Prelude - - +import Control.Lens (over, _3) +import Data.Bifunctor (first, second) +import qualified Data.Map as Map import qualified Data.Set as Set import Prelude.Extras (Show1) +import Unison.Var (Var) +import qualified Unison.ABT as ABT +import qualified Unison.ConstructorType as CT +import Unison.Hash (Hash) +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable import Unison.Hashing.V1.Reference (Reference) import qualified Unison.Hashing.V1.Reference as Reference -import qualified Unison.Referent as Referent +import qualified Unison.Hashing.V1.Reference.Util as Reference.Util import Unison.Hashing.V1.Type (Type) import qualified Unison.Hashing.V1.Type as Type -import qualified Unison.ConstructorType as CT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable -import qualified Unison.Referent' as Referent' +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Prelude +-- import qualified Unison.Referent as Referent +-- import qualified Unison.Referent' as Referent' import Prelude hiding (cycle) type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) -data DeclOrBuiltin v a = - Builtin CT.ConstructorType | Decl (Decl v a) +data DeclOrBuiltin v a + = Builtin CT.ConstructorType + | Decl (Decl v a) deriving (Eq, Show) asDataDecl :: Decl v a -> DataDeclaration v a @@ -50,28 +60,30 @@ declDependencies = either (dependencies . toDataDecl) dependencies constructorType :: Decl v a -> CT.ConstructorType constructorType = \case - Left{} -> CT.Effect - Right{} -> CT.Data + Left {} -> CT.Effect + Right {} -> CT.Data data Modifier = Structural | Unique Text -- | Opaque (Set Reference) deriving (Eq, Ord, Show) -data DataDeclaration v a = DataDeclaration { - modifier :: Modifier, - annotation :: a, - bound :: [v], - constructors' :: [(a, v, Type v a)] -} deriving (Eq, Show, Functor) +data DataDeclaration v a = DataDeclaration + { modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] + } + deriving (Eq, Show, Functor) -newtype EffectDeclaration v a = EffectDeclaration { - toDataDecl :: DataDeclaration v a -} deriving (Eq,Show,Functor) +newtype EffectDeclaration v a = EffectDeclaration + { toDataDecl :: DataDeclaration v a + } + deriving (Eq, Show, Functor) constructorTypes :: DataDeclaration v a -> [Type v a] constructorTypes = (snd <$>) . constructors constructors :: DataDeclaration v a -> [(v, Type v a)] -constructors (DataDeclaration _ _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] +constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] -- -- This function is unsound, since the `rid` and the `decl` have to match. -- -- It should probably be hashed directly from the Decl, once we have a @@ -81,14 +93,68 @@ constructors (DataDeclaration _ _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] -- [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] -- where ct = constructorType decl -constructorIds :: DataDeclaration v a -> [Int] -constructorIds dd = [0 .. length (constructors dd) - 1] - +-- constructorIds :: DataDeclaration v a -> [Int] +-- constructorIds dd = [0 .. length (constructors dd) - 1] dependencies :: Ord v => DataDeclaration v a -> Set Reference dependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) +toABT :: Var v => DataDeclaration v () -> ABT.Term F v () +toABT dd = ABT.tm $ Modified (modifier dd) dd' + where + dd' = ABT.absChain (bound dd) $ ABT.cycle + (ABT.absChain + (fst <$> constructors dd) + (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) + +-- Implementation detail of `hashDecls`, works with unannotated data decls +hashDecls0 :: (Eq v, Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] +hashDecls0 decls = + let abts = toABT <$> decls + ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) + cs = Reference.Util.hashComponents ref abts + in [(v, r) | (v, (r, _)) <- Map.toList cs] + +-- | compute the hashes of these user defined types and update any free vars +-- corresponding to these decls with the resulting hashes +-- +-- data List a = Nil | Cons a (List a) +-- becomes something like +-- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) +-- +-- NOTE: technical limitation, this implementation gives diff results if ctors +-- have the same FQN as one of the types. TODO: assert this and bomb if not +-- satisfied, or else do local mangling and unmangling to ensure this doesn't +-- affect the hash. +hashDecls :: + (Eq v, Var v, Show v) => + Map v (DataDeclaration v a) -> + Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] +hashDecls decls = do + -- todo: make sure all other external references are resolved before calling this + let varToRef = hashDecls0 (void <$> decls) + varToRef' = second Reference.DerivedId <$> varToRef + decls' = bindTypes <$> decls + bindTypes dd = dd {constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd} + typeReferences = Map.fromList (first Name.fromVar <$> varToRef') + -- normalize the order of the constructors based on a hash of their types + sortCtors dd = dd {constructors' = sortOn hash3 $ constructors' dd} + hash3 (_, _, typ) = ABT.hash typ :: Hash + decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' + pure [(v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls']] + +bindReferences :: + Var v => + Set v -> + Map Name.Name Reference -> + DataDeclaration v a -> + Names.ResolutionResult v a (DataDeclaration v a) +bindReferences keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.bindReferences keepFree names ty + pure $ DataDeclaration m a bound constructors + data F a = Type (Type.F a) | LetRec [a] a @@ -99,19 +165,20 @@ data F a instance Hashable1 F where hash1 hashCycle hash e = let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `2` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 2 : case e of - Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] - LetRec bindings body -> - let (hashes, hash') = hashCycle bindings - in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] - Constructors cs -> - let (hashes, _) = hashCycle cs - in tag 2 : map hashed hashes - Modified m t -> - [tag 3, Hashable.accumulateToken m, hashed $ hash t] + in -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + Hashable.accumulate $ + tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] instance Hashable.Hashable Modifier where tokens Structural = [Hashable.Tag 0] - tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] \ No newline at end of file + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs index ad0f71db1e..93077212c3 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs @@ -7,8 +7,8 @@ import Unison.Prelude import Data.Foldable as Foldable hiding (foldMap') import Data.List (intercalate) import qualified Data.Set as Set -import Unison.LabeledDependency (LabeledDependency) -import qualified Unison.LabeledDependency as LD +-- import Unison.LabeledDependency (LabeledDependency) +-- import qualified Unison.LabeledDependency as LD import Unison.Hashing.V1.Reference (Reference) import qualified Unison.Hashing.V1.Type as Type import qualified Unison.Hashable as H diff --git a/parser-typechecker/src/Unison/Hashing/V1/Type.hs b/parser-typechecker/src/Unison/Hashing/V1/Type.hs index 600097118a..da4b183c73 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Type.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Type.hs @@ -61,6 +61,19 @@ bindExternal :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] +bindReferences + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindReferences keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + bindNames :: Var v => Set v diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 17d4527378..3c99d4431e 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -92,6 +92,7 @@ library Unison.DeclPrinter Unison.FileParser Unison.FileParsers + Unison.Hashing.V1.Convert Unison.Hashing.V1.DataDeclaration Unison.Hashing.V1.LabeledDependency Unison.Hashing.V1.Pattern diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 90f6196402..92dc0e4dbf 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -25,7 +25,7 @@ module Unison.DataDeclaration declFields, dependencies, generateRecordAccessors, - hashDecls, + -- hashDecls, unhashComponent, mkDataDecl', mkEffectDecl', @@ -47,15 +47,15 @@ import Prelude.Extras (Show1) import qualified Unison.ABT as ABT import qualified Unison.ConstructorType as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Hash (Hash) -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable +-- import Unison.Hash (Hash) +-- import Unison.Hashable (Hashable1) +-- import qualified Unison.Hashable as Hashable import qualified Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as Reference.Util +-- import qualified Unison.Reference.Util as Reference.Util import qualified Unison.Referent as Referent import qualified Unison.Referent' as Referent' import Unison.Term (Term) @@ -234,25 +234,25 @@ data F a | Modified Modifier a deriving (Functor, Foldable, Show, Show1) -instance Hashable1 F where - hash1 hashCycle hash e = - let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `2` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 2 : case e of - Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] - LetRec bindings body -> - let (hashes, hash') = hashCycle bindings - in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] - Constructors cs -> - let (hashes, _) = hashCycle cs - in tag 2 : map hashed hashes - Modified m t -> - [tag 3, Hashable.accumulateToken m, hashed $ hash t] - -instance Hashable.Hashable Modifier where - tokens Structural = [Hashable.Tag 0] - tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] +-- instance Hashable1 F where +-- hash1 hashCycle hash e = +-- let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) +-- -- Note: start each layer with leading `2` byte, to avoid collisions with +-- -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` +-- in Hashable.accumulate $ tag 2 : case e of +-- Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] +-- LetRec bindings body -> +-- let (hashes, hash') = hashCycle bindings +-- in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] +-- Constructors cs -> +-- let (hashes, _) = hashCycle cs +-- in tag 2 : map hashed hashes +-- Modified m t -> +-- [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +-- instance Hashable.Hashable Modifier where +-- tokens Structural = [Hashable.Tag 0] +-- tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] {- type UpDown = Up | Down @@ -266,13 +266,13 @@ instance Hashable.Hashable Modifier where type Bar a f = Bar Long (Foo a) -} -toABT :: Var v => DataDeclaration v () -> ABT.Term F v () -toABT dd = ABT.tm $ Modified (modifier dd) dd' - where - dd' = ABT.absChain (bound dd) $ ABT.cycle - (ABT.absChain - (fst <$> constructors dd) - (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) +-- toABT :: Var v => DataDeclaration v () -> ABT.Term F v () +-- toABT dd = ABT.tm $ Modified (modifier dd) dd' +-- where +-- dd' = ABT.absChain (bound dd) $ ABT.cycle +-- (ABT.absChain +-- (fst <$> constructors dd) +-- (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) updateDependencies :: Ord v => Map Reference Reference -> Decl v a -> Decl v a updateDependencies typeUpdates decl = back $ dataDecl @@ -308,41 +308,41 @@ unhashComponent m in second unhash2 <$> m' --- Implementation detail of `hashDecls`, works with unannotated data decls -hashDecls0 :: (Eq v, Var v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] -hashDecls0 decls = - let abts = toABT <$> decls - ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) - cs = Reference.Util.hashComponents ref abts - in [ (v, r) | (v, (r, _)) <- Map.toList cs ] - --- | compute the hashes of these user defined types and update any free vars --- corresponding to these decls with the resulting hashes --- --- data List a = Nil | Cons a (List a) --- becomes something like --- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) --- --- NOTE: technical limitation, this implementation gives diff results if ctors --- have the same FQN as one of the types. TODO: assert this and bomb if not --- satisfied, or else do local mangling and unmangling to ensure this doesn't --- affect the hash. -hashDecls - :: (Eq v, Var v) - => Map v (DataDeclaration v a) - -> Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] -hashDecls decls = do - -- todo: make sure all other external references are resolved before calling this - let varToRef = hashDecls0 (void <$> decls) - varToRef' = second Reference.DerivedId <$> varToRef - decls' = bindTypes <$> decls - bindTypes dd = dd { constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd } - typeReferences = Map.fromList (first Name.fromVar <$> varToRef') - -- normalize the order of the constructors based on a hash of their types - sortCtors dd = dd { constructors' = sortOn hash3 $ constructors' dd } - hash3 (_, _, typ) = ABT.hash typ :: Hash - decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' - pure [ (v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls'] ] +-- -- Implementation detail of `hashDecls`, works with unannotated data decls +-- hashDecls0 :: (Eq v, Var v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] +-- hashDecls0 decls = +-- let abts = toABT <$> decls +-- ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) +-- cs = Reference.Util.hashComponents ref abts +-- in [ (v, r) | (v, (r, _)) <- Map.toList cs ] + +-- -- | compute the hashes of these user defined types and update any free vars +-- -- corresponding to these decls with the resulting hashes +-- -- +-- -- data List a = Nil | Cons a (List a) +-- -- becomes something like +-- -- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) +-- -- +-- -- NOTE: technical limitation, this implementation gives diff results if ctors +-- -- have the same FQN as one of the types. TODO: assert this and bomb if not +-- -- satisfied, or else do local mangling and unmangling to ensure this doesn't +-- -- affect the hash. +-- hashDecls +-- :: (Eq v, Var v) +-- => Map v (DataDeclaration v a) +-- -> Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] +-- hashDecls decls = do +-- -- todo: make sure all other external references are resolved before calling this +-- let varToRef = hashDecls0 (void <$> decls) +-- varToRef' = second Reference.DerivedId <$> varToRef +-- decls' = bindTypes <$> decls +-- bindTypes dd = dd { constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd } +-- typeReferences = Map.fromList (first Name.fromVar <$> varToRef') +-- -- normalize the order of the constructors based on a hash of their types +-- sortCtors dd = dd { constructors' = sortOn hash3 $ constructors' dd } +-- hash3 (_, _, typ) = ABT.hash typ :: Hash +-- decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' +-- pure [ (v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls'] ] amap :: (a -> a2) -> Decl v a -> Decl v a2 amap f (Left e) = Left (f <$> e) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 765f8b991d..4242eb997c 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -24,9 +24,9 @@ import Prelude.Extras (Eq1(..), Show1(..)) import Text.Show import qualified Unison.ABT as ABT import qualified Unison.Blank as B -import qualified Unison.Hash as Hash -import Unison.Hashable (Hashable1, accumulateToken) -import qualified Unison.Hashable as Hashable +-- import qualified Unison.Hash as Hash +-- import Unison.Hashable (Hashable1, accumulateToken) +-- import qualified Unison.Hashable as Hashable import Unison.Names3 ( Names0 ) import qualified Unison.Names3 as Names import qualified Unison.Names.ResolutionResult as Names @@ -34,7 +34,7 @@ import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference, pattern Builtin) import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as ReferenceUtil +-- import qualified Unison.Reference.Util as ReferenceUtil import Unison.Referent (Referent, ConstructorId) import qualified Unison.Referent as Referent import Unison.Type (Type) @@ -45,7 +45,7 @@ import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var import Unsafe.Coerce -import Unison.Symbol (Symbol) +-- import Unison.Symbol (Symbol) import qualified Unison.Name as Name import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) @@ -1000,30 +1000,30 @@ unhashComponent m = let in second unhash1 <$> m' -hashComponents - :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) -hashComponents = ReferenceUtil.hashComponents $ refId () +-- hashComponents +-- :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +-- hashComponents = ReferenceUtil.hashComponents $ refId () -hashClosedTerm :: Var v => Term v a -> Reference.Id -hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 +-- hashClosedTerm :: Var v => Term v a -> Reference.Id +-- hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 --- The hash for a constructor -hashConstructor' - :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference -hashConstructor' f r cid = - let --- this is a bit circuitous, but defining everything in terms of hashComponents --- ensure the hashing is always done in the same way - m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) - in case toList m of - [(r, _)] -> Reference.DerivedId r - _ -> error "unpossible" +-- -- The hash for a constructor +-- hashConstructor' +-- :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +-- hashConstructor' f r cid = +-- let +-- -- this is a bit circuitous, but defining everything in terms of hashComponents +-- -- ensure the hashing is always done in the same way +-- m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) +-- in case toList m of +-- [(r, _)] -> Reference.DerivedId r +-- _ -> error "unpossible" -hashConstructor :: Reference -> ConstructorId -> Reference -hashConstructor = hashConstructor' $ constructor () +-- hashConstructor :: Reference -> ConstructorId -> Reference +-- hashConstructor = hashConstructor' $ constructor () -hashRequest :: Reference -> ConstructorId -> Reference -hashRequest = hashConstructor' $ request () +-- hashRequest :: Reference -> ConstructorId -> Reference +-- hashRequest = hashConstructor' $ request () fromReferent :: Ord v => a @@ -1035,75 +1035,75 @@ fromReferent a = \case CT.Data -> constructor a r i CT.Effect -> request a r i -instance Var v => Hashable1 (F v a p) where - hash1 hashCycle hash e - = let (tag, hashed, varint) = - (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) - in - case e of - -- So long as `Reference.Derived` ctors are created using the same - -- hashing function as is used here, this case ensures that references - -- are 'transparent' wrt hash and hashing is unaffected by whether - -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash - -- the same. - Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) - Ref (Reference.Derived h i n) -> Hashable.accumulate - [ tag 1 - , hashed $ Hashable.fromBytes (Hash.toBytes h) - , Hashable.Nat i - , Hashable.Nat n - ] - -- Note: start each layer with leading `1` byte, to avoid collisions - -- with types, which start each layer with leading `0`. - -- See `Hashable1 Type.F` - _ -> - Hashable.accumulate - $ tag 1 - : case e of - Nat i -> [tag 64, accumulateToken i] - Int i -> [tag 65, accumulateToken i] - Float n -> [tag 66, Hashable.Double n] - Boolean b -> [tag 67, accumulateToken b] - Text t -> [tag 68, accumulateToken t] - Char c -> [tag 69, accumulateToken c] - Blank b -> tag 1 : case b of - B.Blank -> [tag 0] - B.Recorded (B.Placeholder _ s) -> - [tag 1, Hashable.Text (Text.pack s)] - B.Recorded (B.Resolve _ s) -> - [tag 2, Hashable.Text (Text.pack s)] - Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] - Ref Reference.Derived {} -> - error "handled above, but GHC can't figure this out" - App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] - Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] - List as -> tag 5 : varint (Sequence.length as) : map - (hashed . hash) - (toList as) - Lam a -> [tag 6, hashed (hash a)] - -- note: we use `hashCycle` to ensure result is independent of - -- let binding order - LetRec _ as a -> case hashCycle as of - (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs - -- here, order is significant, so don't use hashCycle - Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] - If b t f -> - [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] - Request r n -> [tag 10, accumulateToken r, varint n] - Constructor r n -> [tag 12, accumulateToken r, varint n] - Match e branches -> - tag 13 : hashed (hash e) : concatMap h branches - where - h (MatchCase pat guard branch) = concat - [ [accumulateToken pat] - , toList (hashed . hash <$> guard) - , [hashed (hash branch)] - ] - Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] - And x y -> [tag 16, hashed $ hash x, hashed $ hash y] - Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] - TermLink r -> [tag 18, accumulateToken r] - TypeLink r -> [tag 19, accumulateToken r] +-- instance Var v => Hashable1 (F v a p) where +-- hash1 hashCycle hash e +-- = let (tag, hashed, varint) = +-- (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) +-- in +-- case e of +-- -- So long as `Reference.Derived` ctors are created using the same +-- -- hashing function as is used here, this case ensures that references +-- -- are 'transparent' wrt hash and hashing is unaffected by whether +-- -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash +-- -- the same. +-- Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) +-- Ref (Reference.Derived h i n) -> Hashable.accumulate +-- [ tag 1 +-- , hashed $ Hashable.fromBytes (Hash.toBytes h) +-- , Hashable.Nat i +-- , Hashable.Nat n +-- ] +-- -- Note: start each layer with leading `1` byte, to avoid collisions +-- -- with types, which start each layer with leading `0`. +-- -- See `Hashable1 Type.F` +-- _ -> +-- Hashable.accumulate +-- $ tag 1 +-- : case e of +-- Nat i -> [tag 64, accumulateToken i] +-- Int i -> [tag 65, accumulateToken i] +-- Float n -> [tag 66, Hashable.Double n] +-- Boolean b -> [tag 67, accumulateToken b] +-- Text t -> [tag 68, accumulateToken t] +-- Char c -> [tag 69, accumulateToken c] +-- Blank b -> tag 1 : case b of +-- B.Blank -> [tag 0] +-- B.Recorded (B.Placeholder _ s) -> +-- [tag 1, Hashable.Text (Text.pack s)] +-- B.Recorded (B.Resolve _ s) -> +-- [tag 2, Hashable.Text (Text.pack s)] +-- Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] +-- Ref Reference.Derived {} -> +-- error "handled above, but GHC can't figure this out" +-- App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] +-- Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] +-- List as -> tag 5 : varint (Sequence.length as) : map +-- (hashed . hash) +-- (toList as) +-- Lam a -> [tag 6, hashed (hash a)] +-- -- note: we use `hashCycle` to ensure result is independent of +-- -- let binding order +-- LetRec _ as a -> case hashCycle as of +-- (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs +-- -- here, order is significant, so don't use hashCycle +-- Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] +-- If b t f -> +-- [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] +-- Request r n -> [tag 10, accumulateToken r, varint n] +-- Constructor r n -> [tag 12, accumulateToken r, varint n] +-- Match e branches -> +-- tag 13 : hashed (hash e) : concatMap h branches +-- where +-- h (MatchCase pat guard branch) = concat +-- [ [accumulateToken pat] +-- , toList (hashed . hash <$> guard) +-- , [hashed (hash branch)] +-- ] +-- Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] +-- And x y -> [tag 16, hashed $ hash x, hashed $ hash y] +-- Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] +-- TermLink r -> [tag 18, accumulateToken r] +-- TypeLink r -> [tag 19, accumulateToken r] -- mostly boring serialization code below ... diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index ce878fa82f..88dce8a0e9 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -17,12 +17,12 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) import qualified Unison.ABT as ABT -import Unison.Hashable (Hashable1) -import qualified Unison.Hashable as Hashable +-- import Unison.Hashable (Hashable1) +-- import qualified Unison.Hashable as Hashable import qualified Unison.Kind as K import Unison.Reference (Reference) import qualified Unison.Reference as Reference -import qualified Unison.Reference.Util as ReferenceUtil +-- import qualified Unison.Reference.Util as ReferenceUtil import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Settings as Settings @@ -672,43 +672,43 @@ cleanup :: Var v => Type v a -> Type v a cleanup t | not Settings.cleanupTypes = t cleanup t = cleanupVars1 . cleanupAbilityLists $ t -toReference :: (ABT.Var v, Show v) => Type v a -> Reference -toReference (Ref' r) = r --- a bit of normalization - any unused type parameters aren't part of the hash -toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body -toReference t = Reference.Derived (ABT.hash t) 0 1 - -toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference -toReferenceMentions ty = - let (vs, _) = unforall' ty - gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty - in Set.fromList $ toReference . gen <$> ABT.subterms ty - -hashComponents - :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) -hashComponents = ReferenceUtil.hashComponents $ refId () - -instance Hashable1 F where - hash1 hashCycle hash e = - let - (tag, hashed) = (Hashable.Tag, Hashable.Hashed) - -- Note: start each layer with leading `0` byte, to avoid collisions with - -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` - in Hashable.accumulate $ tag 0 : case e of - Ref r -> [tag 0, Hashable.accumulateToken r] - Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] - App a b -> [tag 2, hashed (hash a), hashed (hash b) ] - Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] - -- Example: - -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as - -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from - -- c) {Remote, Abort} (() -> {Abort} ()) - Effects es -> let - (hs, _) = hashCycle es - in tag 4 : map hashed hs - Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] - Forall a -> [tag 6, hashed (hash a)] - IntroOuter a -> [tag 7, hashed (hash a)] +-- toReference :: (ABT.Var v, Show v) => Type v a -> Reference +-- toReference (Ref' r) = r +-- -- a bit of normalization - any unused type parameters aren't part of the hash +-- toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +-- toReference t = Reference.Derived (ABT.hash t) 0 1 + +-- toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +-- toReferenceMentions ty = +-- let (vs, _) = unforall' ty +-- gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty +-- in Set.fromList $ toReference . gen <$> ABT.subterms ty + +-- hashComponents +-- :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +-- hashComponents = ReferenceUtil.hashComponents $ refId () + +-- instance Hashable1 F where +-- hash1 hashCycle hash e = +-- let +-- (tag, hashed) = (Hashable.Tag, Hashable.Hashed) +-- -- Note: start each layer with leading `0` byte, to avoid collisions with +-- -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` +-- in Hashable.accumulate $ tag 0 : case e of +-- Ref r -> [tag 0, Hashable.accumulateToken r] +-- Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] +-- App a b -> [tag 2, hashed (hash a), hashed (hash b) ] +-- Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] +-- -- Example: +-- -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as +-- -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from +-- -- c) {Remote, Abort} (() -> {Abort} ()) +-- Effects es -> let +-- (hs, _) = hashCycle es +-- in tag 4 : map hashed hs +-- Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] +-- Forall a -> [tag 6, hashed (hash a)] +-- IntroOuter a -> [tag 7, hashed (hash a)] instance Show a => Show (F a) where showsPrec = go where From 3b0bb22c1396c4fd966fd4ea8ef157c8814b80a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 9 Sep 2021 15:30:21 -0400 Subject: [PATCH 067/148] Update test --- parser-typechecker/tests/Unison/Test/TypePrinter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/parser-typechecker/tests/Unison/Test/TypePrinter.hs b/parser-typechecker/tests/Unison/Test/TypePrinter.hs index e3cfb6c3f8..4995bc6214 100644 --- a/parser-typechecker/tests/Unison/Test/TypePrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TypePrinter.hs @@ -134,8 +134,7 @@ test = scope "typeprinter" . tests $ , tc "'{e} a" , tc "'{e} (a -> b)" , tc "'{e} (a ->{f} b)" - , pending $ tc "Pair a '{e} b" -- parser hits unexpected ' - , tc_diff_rtt False "Pair a ('{e} b)" "Pair a '{e} b" 80 -- no RTT due to the above + , tc "Pair a ('{e} b)" , tc "'(a -> 'a)" , tc "'()" , tc "'('a)" From bdac2f72cebfa52af2a8e467c1712c49877fe75e Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 9 Sep 2021 13:05:38 -0700 Subject: [PATCH 068/148] whitespace --- parser-typechecker/src/Unison/Codebase.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 18705d702d..bf3f05022c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -212,7 +212,7 @@ isType c r = case r of -- | Sync elements as needed from a remote codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; -- otherwise we try to load the root branch. -importRemoteBranch :: +importRemoteBranch :: forall m v a. MonadIO m => Codebase m v a -> From 90f75626f649ba53a34cc717b9a21b0bbffd199e Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 9 Sep 2021 13:08:39 -0700 Subject: [PATCH 069/148] more whitespace --- parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs | 2 +- parser-typechecker/src/Unison/CommandLine/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 99cebbeec5..146a97736e 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -36,5 +36,5 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) +type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) type WriteRemotePath = (WriteRepo, Path) diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index b1f3202ab2..8d0fbed45d 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -117,7 +117,7 @@ main -> Maybe Server.BaseUrl -> IO () main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do - dir' <- shortenDirectory dir + dir' <- shortenDirectory dir root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase (welcomeCmds, welcomeMsg) <- Welcome.welcome defaultBaseLib root dir' version putPrettyLn welcomeMsg @@ -126,7 +126,7 @@ main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef (welcomeCmds ++ initialInputs) + initialInputsRef <- newIORef (welcomeCmds ++ initialInputs) numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir From d8f1bf9622a681f4f6fc5c0e4213c20e568358dd Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 9 Sep 2021 13:28:13 -0700 Subject: [PATCH 070/148] updating code which determines if codebase is fresh --- parser-typechecker/src/Unison/Codebase.hs | 7 +++++ .../src/Unison/CommandLine/Main.hs | 2 +- .../src/Unison/CommandLine/Welcome.hs | 26 ++++++++++--------- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index bf3f05022c..c4d0c949ca 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -7,6 +7,7 @@ module Unison.Codebase GetRootBranchError (..), getBranchForHash, getCodebaseDir, + isBlank, SyncToDir, addDefsToCodebase, installUcmDependencies, @@ -61,6 +62,7 @@ import Unison.Codebase.Editor.Git (withStatus) import qualified Data.Set as Set import qualified Unison.Util.Relation as Rel import qualified Unison.Type as Type +import Control.Error (rightMay) -- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep -- If not found, attempt to find it in the Codebase (sqlite) @@ -207,6 +209,11 @@ isType c r = case r of Reference.Builtin{} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r +isBlank :: Applicative m => Codebase m v a -> m Bool +isBlank codebase = do + root <- fromMaybe Branch.empty . rightMay <$> getRootBranch codebase + pure (root == Branch.empty) + -- * Git stuff -- | Sync elements as needed from a remote codebase into the local one. diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index 8d0fbed45d..23c1986beb 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -119,7 +119,7 @@ main main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do dir' <- shortenDirectory dir root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - (welcomeCmds, welcomeMsg) <- Welcome.welcome defaultBaseLib root dir' version + (welcomeCmds, welcomeMsg) <- Welcome.welcome defaultBaseLib codebase dir' version putPrettyLn welcomeMsg eventQueue <- Q.newIO do diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index de90ad38ca..4d6ae6fd6d 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -2,12 +2,11 @@ module Unison.CommandLine.Welcome where import Unison.Prelude +import Unison.Codebase (Codebase) +import qualified Unison.Codebase as Codebase import Prelude hiding (readFile, writeFile) -import Unison.Codebase.Branch (Branch) -import qualified Unison.Codebase.Branch as Branch import qualified Unison.Util.Pretty as P import System.Random (randomRIO) -import qualified Data.Map as Map import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.Editor.Input (Input (..), Event) @@ -15,22 +14,25 @@ import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -welcome :: Maybe ReadRemoteNamespace -> Branch IO -> FilePath -> String -> IO ([Either Event Input], P.Pretty P.ColorText) -welcome defaultBaseLib root dir version = do - -- TODO: Move this into `Codebase.isBlank codebase` or something like that? - -- the challenge there is being able to get the root of the codebase without errors - let isBlankCodebase = Map.size (Branch._children (Branch.head root)) == 0 - welcomeMsg <- welcomeMessage dir version +welcome + :: Maybe ReadRemoteNamespace + -> Codebase IO v a + -> FilePath + -> String + -> IO ([Either Event Input], P.Pretty P.ColorText) +welcome defaultBaseLib codebase dir version = do + welcomeMsg <- welcomeMessage dir version + isBlankCodebase <- Codebase.isBlank codebase pure $ case defaultBaseLib of Just ns@(_, _, path) | isBlankCodebase -> let - cmd = + cmd = Right (downloadBase ns) - baseVersion = + baseVersion = P.string (show path) - downloadMsg = + downloadMsg = P.lines [ P.newline <> P.newline , P.wrap ("🕐 Downloading" <> P.blue baseVersion From a8c595ad65d7122c737235cc2caf4ed822c4ef56 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 9 Sep 2021 17:22:11 -0400 Subject: [PATCH 071/148] Hashing.V1.Convert.hashTypeComponents --- .../src/Unison/Builtin/Decls.hs | 7 +- .../src/Unison/Hashing/V1/Convert.hs | 94 ++++++++++++------- 2 files changed, 64 insertions(+), 37 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index 608e26b64b..2bb6855f72 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -28,6 +28,7 @@ import Unison.Type (Type) import qualified Unison.Type as Type import Unison.Var (Var) import qualified Unison.Var as Var +import Control.Monad.Validate (runValidate) lookupDeclRef :: Text -> Reference lookupDeclRef str @@ -117,10 +118,10 @@ failConstructorReferent = Referent.Con testResultRef failConstructorId CT.Data builtinDataDecls :: Var v => [(v, Reference.Id, DataDeclaration v ())] builtinDataDecls = rs1 ++ rs where - rs1 = case hashDecls (const $ Just 1) $ Map.fromList + rs1 = case runValidate . hashDecls (pure $ pure 1) $ Map.fromList [ (v "Link" , link) ] of Right a -> a; Left e -> error $ "builtinDataDecls: " <> show e - rs = case hashDecls (const $ Just 1) $ Map.fromList + rs = case runValidate . hashDecls (pure $ pure 1) $ Map.fromList [ (v "Unit" , unit) , (v "Tuple" , tuple) , (v "Optional" , opt) @@ -306,7 +307,7 @@ builtinDataDecls = rs1 ++ rs builtinEffectDecls :: Var v => [(v, Reference.Id, DD.EffectDeclaration v ())] builtinEffectDecls = - case hashDecls $ Map.fromList [ (v "Exception", exception) ] of + case runValidate . hashDecls (pure $ pure 1) $ Map.fromList [ (v "Exception", exception) ] of Right a -> over _3 DD.EffectDeclaration <$> a Left e -> error $ "builtinEffectDecls: " <> show e where diff --git a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs index d3a98e93d4..c59bd9e2bb 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -module Unison.Hashing.V1.Convert where +module Unison.Hashing.V1.Convert (hashDecls) where import Control.Lens (over, _3) import qualified Control.Lens as Lens @@ -18,6 +18,7 @@ import qualified Unison.Hashing.V1.Type as Hashing.Type import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Reference as Memory.Reference import qualified Unison.Referent as Memory.Referent +import qualified Unison.Term as Memory.Term import qualified Unison.Type as Memory.Type import Unison.Var (Var) @@ -38,44 +39,68 @@ convertResolutionResult = \case Names.TermResolutionFailure v a rs -> TermResolutionFailure v a rs Names.TypeResolutionFailure v a rs -> TypeResolutionFailure v a rs +hashTypeComponents + :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) +hashTypeComponents f memTypes = do + hashingTypes <- traverse (m2hType f) memTypes + let hashingResult = Hashing.Type.hashComponents hashingTypes + pure $ fmap h2mTypeResult hashingResult + +-- hashTermComponents :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a) +-- hashTermComponents f memTerms = undefined + hashDecls :: - (Eq v, Var v) => + Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.DD.DataDeclaration v a) -> ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] hashDecls f memDecls = do - hashingDecls <- traverse m2hDecl memDecls + hashingDecls <- Validate.mapErrors (fmap CycleResolutionFailure) $ traverse (m2hDecl f) memDecls hashingResult <- convertResolutionResult $ Hashing.DD.hashDecls hashingDecls pure $ map h2mDeclResult hashingResult - where - lookupHash :: Hash -> ResolutionResult v a Hashing.Reference.Size - lookupHash h = case f h of - Just size -> pure size - Nothing -> Validate.refute . pure $ CycleResolutionFailure h - - m2hDecl :: Ord v => Memory.DD.DataDeclaration v a -> ResolutionResult v a (Hashing.DD.DataDeclaration v a) - m2hDecl (Memory.DD.DataDeclaration mod ann bound ctors) = - Hashing.DD.DataDeclaration (m2hModifier mod) ann bound - <$> traverse (Lens.mapMOf _3 m2hType) ctors - - m2hType :: Ord v => Memory.Type.Type v a -> ResolutionResult v a (Hashing.Type.Type v a) - m2hType = ABT.transformM \case - Memory.Type.Ref ref -> Hashing.Type.Ref <$> m2hReference ref - Memory.Type.Arrow a1 a1' -> pure $ Hashing.Type.Arrow a1 a1' - Memory.Type.Ann a1 ki -> pure $ Hashing.Type.Ann a1 ki - Memory.Type.App a1 a1' -> pure $ Hashing.Type.App a1 a1' - Memory.Type.Effect a1 a1' -> pure $ Hashing.Type.Effect a1 a1' - Memory.Type.Effects a1s -> pure $ Hashing.Type.Effects a1s - Memory.Type.Forall a1 -> pure $ Hashing.Type.Forall a1 - Memory.Type.IntroOuter a1 -> pure $ Hashing.Type.IntroOuter a1 - - m2hReference :: Memory.Reference.Reference -> ResolutionResult v a (Hashing.Reference.Reference) - m2hReference = \case - Memory.Reference.Builtin t -> pure $ Hashing.Reference.Builtin t - Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId <$> m2hReferenceId d - - m2hReferenceId :: Memory.Reference.Id -> ResolutionResult v a (Hashing.Reference.Id) - m2hReferenceId (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i <$> lookupHash h + +m2hDecl :: + Ord v => + (Hash -> Maybe Hashing.Reference.Size) -> + Memory.DD.DataDeclaration v a -> + Validate (Seq Hash) (Hashing.DD.DataDeclaration v a) +m2hDecl f (Memory.DD.DataDeclaration mod ann bound ctors) = + Hashing.DD.DataDeclaration (m2hModifier mod) ann bound + <$> traverse (Lens.mapMOf _3 (m2hType f)) ctors + +lookupHash :: (Hash -> Maybe Hashing.Reference.Size) -> Hash -> Validate (Seq Hash) Hashing.Reference.Size +lookupHash f h = case f h of + Just size -> pure size + Nothing -> Validate.refute $ pure h + +m2hType :: + Ord v => + (Hash -> Maybe Hashing.Reference.Size) -> + Memory.Type.Type v a -> + Validate (Seq Hash) (Hashing.Type.Type v a) +m2hType f = ABT.transformM \case + Memory.Type.Ref ref -> Hashing.Type.Ref <$> m2hReference f ref + Memory.Type.Arrow a1 a1' -> pure $ Hashing.Type.Arrow a1 a1' + Memory.Type.Ann a1 ki -> pure $ Hashing.Type.Ann a1 ki + Memory.Type.App a1 a1' -> pure $ Hashing.Type.App a1 a1' + Memory.Type.Effect a1 a1' -> pure $ Hashing.Type.Effect a1 a1' + Memory.Type.Effects a1s -> pure $ Hashing.Type.Effects a1s + Memory.Type.Forall a1 -> pure $ Hashing.Type.Forall a1 + Memory.Type.IntroOuter a1 -> pure $ Hashing.Type.IntroOuter a1 + +m2hReference :: + (Hash -> Maybe Hashing.Reference.Size) -> + Memory.Reference.Reference -> + Validate (Seq Hash) Hashing.Reference.Reference +m2hReference f = \case + Memory.Reference.Builtin t -> pure $ Hashing.Reference.Builtin t + Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId <$> m2hReferenceId f d + +m2hReferenceId :: + (Hash -> Maybe Hashing.Reference.Size) -> + Memory.Reference.Id -> + Validate (Seq Hash) Hashing.Reference.Id +m2hReferenceId f (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i <$> lookupHash f h h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier h2mModifier = \case @@ -90,6 +115,9 @@ m2hModifier = \case h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) +h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) +h2mTypeResult (id, dd) = (h2mReferenceId id, h2mType dd) + h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) @@ -112,5 +140,3 @@ h2mReference = \case h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n - - From 66f32ce0077fa3ae8bb407c36b94abaaa14ef743 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Fri, 10 Sep 2021 10:40:23 -0700 Subject: [PATCH 072/148] update transcript output --- unison-src/transcripts/alias-many.output.md | 778 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 6 files changed, 414 insertions(+), 412 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 5a574d173d..668d38d477 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -20,442 +20,444 @@ Let's try it! 1. builtin type Any 2. Any.Any : a -> Any - 3. builtin type Boolean - 4. Boolean.not : Boolean -> Boolean - 5. bug : a -> b - 6. builtin type Bytes - 7. Bytes.++ : Bytes -> Bytes -> Bytes - 8. Bytes.at : Nat -> Bytes -> Optional Nat - 9. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) - 10. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) - 11. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) - 12. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) - 13. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) - 14. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) - 15. Bytes.drop : Nat -> Bytes -> Bytes - 16. Bytes.empty : Bytes - 17. Bytes.encodeNat16be : Nat -> Bytes - 18. Bytes.encodeNat16le : Nat -> Bytes - 19. Bytes.encodeNat32be : Nat -> Bytes - 20. Bytes.encodeNat32le : Nat -> Bytes - 21. Bytes.encodeNat64be : Nat -> Bytes - 22. Bytes.encodeNat64le : Nat -> Bytes - 23. Bytes.flatten : Bytes -> Bytes - 24. Bytes.fromBase16 : Bytes -> Either Text Bytes - 25. Bytes.fromBase32 : Bytes -> Either Text Bytes - 26. Bytes.fromBase64 : Bytes -> Either Text Bytes - 27. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 28. Bytes.fromList : [Nat] -> Bytes - 29. Bytes.size : Bytes -> Nat - 30. Bytes.take : Nat -> Bytes -> Bytes - 31. Bytes.toBase16 : Bytes -> Bytes - 32. Bytes.toBase32 : Bytes -> Bytes - 33. Bytes.toBase64 : Bytes -> Bytes - 34. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 35. Bytes.toList : Bytes -> [Nat] - 36. builtin type Char - 37. Char.fromNat : Nat -> Char - 38. Char.toNat : Char -> Nat - 39. Char.toText : Char -> Text - 40. builtin type Code - 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 42. Code.dependencies : Code -> [Term] - 43. Code.deserialize : Bytes -> Either Text Code - 44. Code.isMissing : Term ->{IO} Boolean - 45. Code.lookup : Term ->{IO} Optional Code - 46. Code.serialize : Code -> Bytes - 47. crypto.hash : HashAlgorithm -> a -> Bytes - 48. builtin type crypto.HashAlgorithm - 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 58. crypto.hmacBytes : HashAlgorithm + 3. Any.unsafeExtract : Any -> a + 4. builtin type Boolean + 5. Boolean.not : Boolean -> Boolean + 6. bug : a -> b + 7. builtin type Bytes + 8. Bytes.++ : Bytes -> Bytes -> Bytes + 9. Bytes.at : Nat -> Bytes -> Optional Nat + 10. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) + 11. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) + 12. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) + 13. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) + 14. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) + 15. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) + 16. Bytes.drop : Nat -> Bytes -> Bytes + 17. Bytes.empty : Bytes + 18. Bytes.encodeNat16be : Nat -> Bytes + 19. Bytes.encodeNat16le : Nat -> Bytes + 20. Bytes.encodeNat32be : Nat -> Bytes + 21. Bytes.encodeNat32le : Nat -> Bytes + 22. Bytes.encodeNat64be : Nat -> Bytes + 23. Bytes.encodeNat64le : Nat -> Bytes + 24. Bytes.flatten : Bytes -> Bytes + 25. Bytes.fromBase16 : Bytes -> Either Text Bytes + 26. Bytes.fromBase32 : Bytes -> Either Text Bytes + 27. Bytes.fromBase64 : Bytes -> Either Text Bytes + 28. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes + 29. Bytes.fromList : [Nat] -> Bytes + 30. Bytes.size : Bytes -> Nat + 31. Bytes.take : Nat -> Bytes -> Bytes + 32. Bytes.toBase16 : Bytes -> Bytes + 33. Bytes.toBase32 : Bytes -> Bytes + 34. Bytes.toBase64 : Bytes -> Bytes + 35. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 36. Bytes.toList : Bytes -> [Nat] + 37. builtin type Char + 38. Char.fromNat : Nat -> Char + 39. Char.toNat : Char -> Nat + 40. Char.toText : Char -> Text + 41. builtin type Code + 42. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 43. Code.dependencies : Code -> [Term] + 44. Code.deserialize : Bytes -> Either Text Code + 45. Code.isMissing : Term ->{IO} Boolean + 46. Code.lookup : Term ->{IO} Optional Code + 47. Code.serialize : Code -> Bytes + 48. crypto.hash : HashAlgorithm -> a -> Bytes + 49. builtin type crypto.HashAlgorithm + 50. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 51. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 52. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 53. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 54. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 55. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 56. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 57. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 58. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 59. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 59. Debug.watch : Text -> a -> a - 60. unique type Doc - 61. Doc.Blob : Text -> Doc - 62. Doc.Evaluate : Term -> Doc - 63. Doc.Join : [Doc] -> Doc - 64. Doc.Link : Link -> Doc - 65. Doc.Signature : Term -> Doc - 66. Doc.Source : Link -> Doc - 67. structural type Either a b - 68. Either.Left : a -> Either a b - 69. Either.Right : b -> Either a b - 70. structural ability Exception - 71. Exception.raise : Failure ->{Exception} x - 72. builtin type Float - 73. Float.* : Float -> Float -> Float - 74. Float.+ : Float -> Float -> Float - 75. Float.- : Float -> Float -> Float - 76. Float./ : Float -> Float -> Float - 77. Float.abs : Float -> Float - 78. Float.acos : Float -> Float - 79. Float.acosh : Float -> Float - 80. Float.asin : Float -> Float - 81. Float.asinh : Float -> Float - 82. Float.atan : Float -> Float - 83. Float.atan2 : Float -> Float -> Float - 84. Float.atanh : Float -> Float - 85. Float.ceiling : Float -> Int - 86. Float.cos : Float -> Float - 87. Float.cosh : Float -> Float - 88. Float.eq : Float -> Float -> Boolean - 89. Float.exp : Float -> Float - 90. Float.floor : Float -> Int - 91. Float.fromRepresentation : Nat -> Float - 92. Float.fromText : Text -> Optional Float - 93. Float.gt : Float -> Float -> Boolean - 94. Float.gteq : Float -> Float -> Boolean - 95. Float.log : Float -> Float - 96. Float.logBase : Float -> Float -> Float - 97. Float.lt : Float -> Float -> Boolean - 98. Float.lteq : Float -> Float -> Boolean - 99. Float.max : Float -> Float -> Float - 100. Float.min : Float -> Float -> Float - 101. Float.pow : Float -> Float -> Float - 102. Float.round : Float -> Int - 103. Float.sin : Float -> Float - 104. Float.sinh : Float -> Float - 105. Float.sqrt : Float -> Float - 106. Float.tan : Float -> Float - 107. Float.tanh : Float -> Float - 108. Float.toRepresentation : Float -> Nat - 109. Float.toText : Float -> Text - 110. Float.truncate : Float -> Int - 111. builtin type Int - 112. Int.* : Int -> Int -> Int - 113. Int.+ : Int -> Int -> Int - 114. Int.- : Int -> Int -> Int - 115. Int./ : Int -> Int -> Int - 116. Int.and : Int -> Int -> Int - 117. Int.complement : Int -> Int - 118. Int.eq : Int -> Int -> Boolean - 119. Int.fromRepresentation : Nat -> Int - 120. Int.fromText : Text -> Optional Int - 121. Int.gt : Int -> Int -> Boolean - 122. Int.gteq : Int -> Int -> Boolean - 123. Int.increment : Int -> Int - 124. Int.isEven : Int -> Boolean - 125. Int.isOdd : Int -> Boolean - 126. Int.leadingZeros : Int -> Nat - 127. Int.lt : Int -> Int -> Boolean - 128. Int.lteq : Int -> Int -> Boolean - 129. Int.mod : Int -> Int -> Int - 130. Int.negate : Int -> Int - 131. Int.or : Int -> Int -> Int - 132. Int.popCount : Int -> Nat - 133. Int.pow : Int -> Nat -> Int - 134. Int.shiftLeft : Int -> Nat -> Int - 135. Int.shiftRight : Int -> Nat -> Int - 136. Int.signum : Int -> Int - 137. Int.toFloat : Int -> Float - 138. Int.toRepresentation : Int -> Nat - 139. Int.toText : Int -> Text - 140. Int.trailingZeros : Int -> Nat - 141. Int.truncate0 : Int -> Nat - 142. Int.xor : Int -> Int -> Int - 143. unique type io2.BufferMode - 144. io2.BufferMode.BlockBuffering : BufferMode - 145. io2.BufferMode.LineBuffering : BufferMode - 146. io2.BufferMode.NoBuffering : BufferMode - 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 148. unique type io2.Failure - 149. io2.Failure.Failure : Type -> Text -> Any -> Failure - 150. unique type io2.FileMode - 151. io2.FileMode.Append : FileMode - 152. io2.FileMode.Read : FileMode - 153. io2.FileMode.ReadWrite : FileMode - 154. io2.FileMode.Write : FileMode - 155. builtin type io2.Handle - 156. builtin type io2.IO - 157. io2.IO.clientSocket.impl : Text + 60. Debug.watch : Text -> a -> a + 61. unique type Doc + 62. Doc.Blob : Text -> Doc + 63. Doc.Evaluate : Term -> Doc + 64. Doc.Join : [Doc] -> Doc + 65. Doc.Link : Link -> Doc + 66. Doc.Signature : Term -> Doc + 67. Doc.Source : Link -> Doc + 68. structural type Either a b + 69. Either.Left : a -> Either a b + 70. Either.Right : b -> Either a b + 71. structural ability Exception + 72. Exception.raise : Failure ->{Exception} x + 73. builtin type Float + 74. Float.* : Float -> Float -> Float + 75. Float.+ : Float -> Float -> Float + 76. Float.- : Float -> Float -> Float + 77. Float./ : Float -> Float -> Float + 78. Float.abs : Float -> Float + 79. Float.acos : Float -> Float + 80. Float.acosh : Float -> Float + 81. Float.asin : Float -> Float + 82. Float.asinh : Float -> Float + 83. Float.atan : Float -> Float + 84. Float.atan2 : Float -> Float -> Float + 85. Float.atanh : Float -> Float + 86. Float.ceiling : Float -> Int + 87. Float.cos : Float -> Float + 88. Float.cosh : Float -> Float + 89. Float.eq : Float -> Float -> Boolean + 90. Float.exp : Float -> Float + 91. Float.floor : Float -> Int + 92. Float.fromRepresentation : Nat -> Float + 93. Float.fromText : Text -> Optional Float + 94. Float.gt : Float -> Float -> Boolean + 95. Float.gteq : Float -> Float -> Boolean + 96. Float.log : Float -> Float + 97. Float.logBase : Float -> Float -> Float + 98. Float.lt : Float -> Float -> Boolean + 99. Float.lteq : Float -> Float -> Boolean + 100. Float.max : Float -> Float -> Float + 101. Float.min : Float -> Float -> Float + 102. Float.pow : Float -> Float -> Float + 103. Float.round : Float -> Int + 104. Float.sin : Float -> Float + 105. Float.sinh : Float -> Float + 106. Float.sqrt : Float -> Float + 107. Float.tan : Float -> Float + 108. Float.tanh : Float -> Float + 109. Float.toRepresentation : Float -> Nat + 110. Float.toText : Float -> Text + 111. Float.truncate : Float -> Int + 112. builtin type Int + 113. Int.* : Int -> Int -> Int + 114. Int.+ : Int -> Int -> Int + 115. Int.- : Int -> Int -> Int + 116. Int./ : Int -> Int -> Int + 117. Int.and : Int -> Int -> Int + 118. Int.complement : Int -> Int + 119. Int.eq : Int -> Int -> Boolean + 120. Int.fromRepresentation : Nat -> Int + 121. Int.fromText : Text -> Optional Int + 122. Int.gt : Int -> Int -> Boolean + 123. Int.gteq : Int -> Int -> Boolean + 124. Int.increment : Int -> Int + 125. Int.isEven : Int -> Boolean + 126. Int.isOdd : Int -> Boolean + 127. Int.leadingZeros : Int -> Nat + 128. Int.lt : Int -> Int -> Boolean + 129. Int.lteq : Int -> Int -> Boolean + 130. Int.mod : Int -> Int -> Int + 131. Int.negate : Int -> Int + 132. Int.or : Int -> Int -> Int + 133. Int.popCount : Int -> Nat + 134. Int.pow : Int -> Nat -> Int + 135. Int.shiftLeft : Int -> Nat -> Int + 136. Int.shiftRight : Int -> Nat -> Int + 137. Int.signum : Int -> Int + 138. Int.toFloat : Int -> Float + 139. Int.toRepresentation : Int -> Nat + 140. Int.toText : Int -> Text + 141. Int.trailingZeros : Int -> Nat + 142. Int.truncate0 : Int -> Nat + 143. Int.xor : Int -> Int -> Int + 144. unique type io2.BufferMode + 145. io2.BufferMode.BlockBuffering : BufferMode + 146. io2.BufferMode.LineBuffering : BufferMode + 147. io2.BufferMode.NoBuffering : BufferMode + 148. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 149. unique type io2.Failure + 150. io2.Failure.Failure : Type -> Text -> Any -> Failure + 151. unique type io2.FileMode + 152. io2.FileMode.Append : FileMode + 153. io2.FileMode.Read : FileMode + 154. io2.FileMode.ReadWrite : FileMode + 155. io2.FileMode.Write : FileMode + 156. builtin type io2.Handle + 157. builtin type io2.IO + 158. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 160. io2.IO.createDirectory.impl : Text + 159. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 160. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 161. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 161. io2.IO.createTempDirectory.impl : Text + 162. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 163. io2.IO.directoryContents.impl : Text + 163. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 164. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 164. io2.IO.fileExists.impl : Text + 165. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 166. io2.IO.getBuffering.impl : Handle + 166. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 167. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 167. io2.IO.getBytes.impl : Handle + 168. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 168. io2.IO.getCurrentDirectory.impl : '{IO} Either + 169. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 171. io2.IO.getFileTimestamp.impl : Text + 170. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 171. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 172. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 174. io2.IO.handlePosition.impl : Handle + 173. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 174. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 175. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 175. io2.IO.isDirectory.impl : Text + 176. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 176. io2.IO.isFileEOF.impl : Handle + 177. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 177. io2.IO.isFileOpen.impl : Handle + 178. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isSeekable.impl : Handle + 179. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 181. io2.IO.openFile.impl : Text + 180. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 181. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 182. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 182. io2.IO.putBytes.impl : Handle + 183. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 183. io2.IO.ref : a ->{IO} Ref {IO} a - 184. io2.IO.removeDirectory.impl : Text + 184. io2.IO.ref : a ->{IO} Ref {IO} a + 185. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 186. io2.IO.renameDirectory.impl : Text + 186. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 187. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 187. io2.IO.renameFile.impl : Text + 188. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 188. io2.IO.seekHandle.impl : Handle + 189. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 189. io2.IO.serverSocket.impl : Optional Text + 190. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 190. io2.IO.setBuffering.impl : Handle + 191. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 191. io2.IO.setCurrentDirectory.impl : Text + 192. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 192. io2.IO.socketAccept.impl : Socket + 193. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 193. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 194. io2.IO.socketReceive.impl : Socket + 194. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 195. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 195. io2.IO.socketSend.impl : Socket + 196. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 196. io2.IO.stdHandle : StdHandle -> Handle - 197. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 198. unique type io2.IOError - 199. io2.IOError.AlreadyExists : IOError - 200. io2.IOError.EOF : IOError - 201. io2.IOError.IllegalOperation : IOError - 202. io2.IOError.NoSuchThing : IOError - 203. io2.IOError.PermissionDenied : IOError - 204. io2.IOError.ResourceBusy : IOError - 205. io2.IOError.ResourceExhausted : IOError - 206. io2.IOError.UserError : IOError - 207. unique type io2.IOFailure - 208. builtin type io2.MVar - 209. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 210. io2.MVar.new : a ->{IO} MVar a - 211. io2.MVar.newEmpty : '{IO} MVar a - 212. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 213. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 214. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 215. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 216. io2.MVar.tryPut.impl : MVar a + 197. io2.IO.stdHandle : StdHandle -> Handle + 198. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 199. unique type io2.IOError + 200. io2.IOError.AlreadyExists : IOError + 201. io2.IOError.EOF : IOError + 202. io2.IOError.IllegalOperation : IOError + 203. io2.IOError.NoSuchThing : IOError + 204. io2.IOError.PermissionDenied : IOError + 205. io2.IOError.ResourceBusy : IOError + 206. io2.IOError.ResourceExhausted : IOError + 207. io2.IOError.UserError : IOError + 208. unique type io2.IOFailure + 209. builtin type io2.MVar + 210. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 211. io2.MVar.new : a ->{IO} MVar a + 212. io2.MVar.newEmpty : '{IO} MVar a + 213. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 214. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 215. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 216. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 217. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 217. io2.MVar.tryRead.impl : MVar a + 218. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 218. io2.MVar.tryTake : MVar a ->{IO} Optional a - 219. unique type io2.SeekMode - 220. io2.SeekMode.AbsoluteSeek : SeekMode - 221. io2.SeekMode.RelativeSeek : SeekMode - 222. io2.SeekMode.SeekFromEnd : SeekMode - 223. builtin type io2.Socket - 224. unique type io2.StdHandle - 225. io2.StdHandle.StdErr : StdHandle - 226. io2.StdHandle.StdIn : StdHandle - 227. io2.StdHandle.StdOut : StdHandle - 228. builtin type io2.STM - 229. io2.STM.atomically : '{STM} a ->{IO} a - 230. io2.STM.retry : '{STM} a - 231. builtin type io2.ThreadId - 232. builtin type io2.Tls - 233. builtin type io2.Tls.Cipher - 234. builtin type io2.Tls.ClientConfig - 235. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 219. io2.MVar.tryTake : MVar a ->{IO} Optional a + 220. unique type io2.SeekMode + 221. io2.SeekMode.AbsoluteSeek : SeekMode + 222. io2.SeekMode.RelativeSeek : SeekMode + 223. io2.SeekMode.SeekFromEnd : SeekMode + 224. builtin type io2.Socket + 225. unique type io2.StdHandle + 226. io2.StdHandle.StdErr : StdHandle + 227. io2.StdHandle.StdIn : StdHandle + 228. io2.StdHandle.StdOut : StdHandle + 229. builtin type io2.STM + 230. io2.STM.atomically : '{STM} a ->{IO} a + 231. io2.STM.retry : '{STM} a + 232. builtin type io2.ThreadId + 233. builtin type io2.Tls + 234. builtin type io2.Tls.Cipher + 235. builtin type io2.Tls.ClientConfig + 236. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 236. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 237. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 237. io2.Tls.ClientConfig.default : Text + 238. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 238. io2.Tls.ClientConfig.versions.set : [Version] + 239. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 239. io2.Tls.decodeCert.impl : Bytes + 240. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 240. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 241. io2.Tls.encodeCert : SignedCert -> Bytes - 242. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 243. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 244. io2.Tls.newClient.impl : ClientConfig + 241. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 242. io2.Tls.encodeCert : SignedCert -> Bytes + 243. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 244. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 245. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 245. io2.Tls.newServer.impl : ServerConfig + 246. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 246. builtin type io2.Tls.PrivateKey - 247. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 248. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 249. builtin type io2.Tls.ServerConfig - 250. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 247. builtin type io2.Tls.PrivateKey + 248. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 249. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 250. builtin type io2.Tls.ServerConfig + 251. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 251. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 252. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 252. io2.Tls.ServerConfig.default : [SignedCert] + 253. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 253. io2.Tls.ServerConfig.versions.set : [Version] + 254. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 254. builtin type io2.Tls.SignedCert - 255. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 256. builtin type io2.Tls.Version - 257. unique type io2.TlsFailure - 258. builtin type io2.TVar - 259. io2.TVar.new : a ->{STM} TVar a - 260. io2.TVar.newIO : a ->{IO} TVar a - 261. io2.TVar.read : TVar a ->{STM} a - 262. io2.TVar.readIO : TVar a ->{IO} a - 263. io2.TVar.swap : TVar a -> a ->{STM} a - 264. io2.TVar.write : TVar a -> a ->{STM} () - 265. unique type IsPropagated - 266. IsPropagated.IsPropagated : IsPropagated - 267. unique type IsTest - 268. IsTest.IsTest : IsTest - 269. unique type Link - 270. builtin type Link.Term - 271. Link.Term : Term -> Link - 272. builtin type Link.Type - 273. Link.Type : Type -> Link - 274. builtin type List - 275. List.++ : [a] -> [a] -> [a] - 276. List.+: : a -> [a] -> [a] - 277. List.:+ : [a] -> a -> [a] - 278. List.at : Nat -> [a] -> Optional a - 279. List.cons : a -> [a] -> [a] - 280. List.drop : Nat -> [a] -> [a] - 281. List.empty : [a] - 282. List.size : [a] -> Nat - 283. List.snoc : [a] -> a -> [a] - 284. List.take : Nat -> [a] -> [a] - 285. metadata.isPropagated : IsPropagated - 286. metadata.isTest : IsTest - 287. builtin type Nat - 288. Nat.* : Nat -> Nat -> Nat - 289. Nat.+ : Nat -> Nat -> Nat - 290. Nat./ : Nat -> Nat -> Nat - 291. Nat.and : Nat -> Nat -> Nat - 292. Nat.complement : Nat -> Nat - 293. Nat.drop : Nat -> Nat -> Nat - 294. Nat.eq : Nat -> Nat -> Boolean - 295. Nat.fromText : Text -> Optional Nat - 296. Nat.gt : Nat -> Nat -> Boolean - 297. Nat.gteq : Nat -> Nat -> Boolean - 298. Nat.increment : Nat -> Nat - 299. Nat.isEven : Nat -> Boolean - 300. Nat.isOdd : Nat -> Boolean - 301. Nat.leadingZeros : Nat -> Nat - 302. Nat.lt : Nat -> Nat -> Boolean - 303. Nat.lteq : Nat -> Nat -> Boolean - 304. Nat.mod : Nat -> Nat -> Nat - 305. Nat.or : Nat -> Nat -> Nat - 306. Nat.popCount : Nat -> Nat - 307. Nat.pow : Nat -> Nat -> Nat - 308. Nat.shiftLeft : Nat -> Nat -> Nat - 309. Nat.shiftRight : Nat -> Nat -> Nat - 310. Nat.sub : Nat -> Nat -> Int - 311. Nat.toFloat : Nat -> Float - 312. Nat.toInt : Nat -> Int - 313. Nat.toText : Nat -> Text - 314. Nat.trailingZeros : Nat -> Nat - 315. Nat.xor : Nat -> Nat -> Nat - 316. structural type Optional a - 317. Optional.None : Optional a - 318. Optional.Some : a -> Optional a - 319. builtin type Ref - 320. Ref.read : Ref g a ->{g} a - 321. Ref.write : Ref g a -> a ->{g} () - 322. builtin type Request - 323. builtin type Scope - 324. Scope.ref : a ->{Scope s} Ref {Scope s} a - 325. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 326. structural type SeqView a b - 327. SeqView.VElem : a -> b -> SeqView a b - 328. SeqView.VEmpty : SeqView a b - 329. unique type Test.Result - 330. Test.Result.Fail : Text -> Result - 331. Test.Result.Ok : Text -> Result - 332. builtin type Text - 333. Text.!= : Text -> Text -> Boolean - 334. Text.++ : Text -> Text -> Text - 335. Text.drop : Nat -> Text -> Text - 336. Text.empty : Text - 337. Text.eq : Text -> Text -> Boolean - 338. Text.fromCharList : [Char] -> Text - 339. Text.fromUtf8.impl : Bytes -> Either Failure Text - 340. Text.gt : Text -> Text -> Boolean - 341. Text.gteq : Text -> Text -> Boolean - 342. Text.lt : Text -> Text -> Boolean - 343. Text.lteq : Text -> Text -> Boolean - 344. Text.repeat : Nat -> Text -> Text - 345. Text.size : Text -> Nat - 346. Text.take : Nat -> Text -> Text - 347. Text.toCharList : Text -> [Char] - 348. Text.toUtf8 : Text -> Bytes - 349. Text.uncons : Text -> Optional (Char, Text) - 350. Text.unsnoc : Text -> Optional (Text, Char) - 351. todo : a -> b - 352. structural type Tuple a b - 353. Tuple.Cons : a -> b -> Tuple a b - 354. structural type Unit - 355. Unit.Unit : () - 356. Universal.< : a -> a -> Boolean - 357. Universal.<= : a -> a -> Boolean - 358. Universal.== : a -> a -> Boolean - 359. Universal.> : a -> a -> Boolean - 360. Universal.>= : a -> a -> Boolean - 361. Universal.compare : a -> a -> Int - 362. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 363. builtin type Value - 364. Value.dependencies : Value -> [Term] - 365. Value.deserialize : Bytes -> Either Text Value - 366. Value.load : Value ->{IO} Either [Term] a - 367. Value.serialize : Value -> Bytes - 368. Value.value : a -> Value + 255. builtin type io2.Tls.SignedCert + 256. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 257. builtin type io2.Tls.Version + 258. unique type io2.TlsFailure + 259. builtin type io2.TVar + 260. io2.TVar.new : a ->{STM} TVar a + 261. io2.TVar.newIO : a ->{IO} TVar a + 262. io2.TVar.read : TVar a ->{STM} a + 263. io2.TVar.readIO : TVar a ->{IO} a + 264. io2.TVar.swap : TVar a -> a ->{STM} a + 265. io2.TVar.write : TVar a -> a ->{STM} () + 266. unique type IsPropagated + 267. IsPropagated.IsPropagated : IsPropagated + 268. unique type IsTest + 269. IsTest.IsTest : IsTest + 270. unique type Link + 271. builtin type Link.Term + 272. Link.Term : Term -> Link + 273. Link.Term.toText : Term -> Text + 274. builtin type Link.Type + 275. Link.Type : Type -> Link + 276. builtin type List + 277. List.++ : [a] -> [a] -> [a] + 278. List.+: : a -> [a] -> [a] + 279. List.:+ : [a] -> a -> [a] + 280. List.at : Nat -> [a] -> Optional a + 281. List.cons : a -> [a] -> [a] + 282. List.drop : Nat -> [a] -> [a] + 283. List.empty : [a] + 284. List.size : [a] -> Nat + 285. List.snoc : [a] -> a -> [a] + 286. List.take : Nat -> [a] -> [a] + 287. metadata.isPropagated : IsPropagated + 288. metadata.isTest : IsTest + 289. builtin type Nat + 290. Nat.* : Nat -> Nat -> Nat + 291. Nat.+ : Nat -> Nat -> Nat + 292. Nat./ : Nat -> Nat -> Nat + 293. Nat.and : Nat -> Nat -> Nat + 294. Nat.complement : Nat -> Nat + 295. Nat.drop : Nat -> Nat -> Nat + 296. Nat.eq : Nat -> Nat -> Boolean + 297. Nat.fromText : Text -> Optional Nat + 298. Nat.gt : Nat -> Nat -> Boolean + 299. Nat.gteq : Nat -> Nat -> Boolean + 300. Nat.increment : Nat -> Nat + 301. Nat.isEven : Nat -> Boolean + 302. Nat.isOdd : Nat -> Boolean + 303. Nat.leadingZeros : Nat -> Nat + 304. Nat.lt : Nat -> Nat -> Boolean + 305. Nat.lteq : Nat -> Nat -> Boolean + 306. Nat.mod : Nat -> Nat -> Nat + 307. Nat.or : Nat -> Nat -> Nat + 308. Nat.popCount : Nat -> Nat + 309. Nat.pow : Nat -> Nat -> Nat + 310. Nat.shiftLeft : Nat -> Nat -> Nat + 311. Nat.shiftRight : Nat -> Nat -> Nat + 312. Nat.sub : Nat -> Nat -> Int + 313. Nat.toFloat : Nat -> Float + 314. Nat.toInt : Nat -> Int + 315. Nat.toText : Nat -> Text + 316. Nat.trailingZeros : Nat -> Nat + 317. Nat.xor : Nat -> Nat -> Nat + 318. structural type Optional a + 319. Optional.None : Optional a + 320. Optional.Some : a -> Optional a + 321. builtin type Ref + 322. Ref.read : Ref g a ->{g} a + 323. Ref.write : Ref g a -> a ->{g} () + 324. builtin type Request + 325. builtin type Scope + 326. Scope.ref : a ->{Scope s} Ref {Scope s} a + 327. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 328. structural type SeqView a b + 329. SeqView.VElem : a -> b -> SeqView a b + 330. SeqView.VEmpty : SeqView a b + 331. unique type Test.Result + 332. Test.Result.Fail : Text -> Result + 333. Test.Result.Ok : Text -> Result + 334. builtin type Text + 335. Text.!= : Text -> Text -> Boolean + 336. Text.++ : Text -> Text -> Text + 337. Text.drop : Nat -> Text -> Text + 338. Text.empty : Text + 339. Text.eq : Text -> Text -> Boolean + 340. Text.fromCharList : [Char] -> Text + 341. Text.fromUtf8.impl : Bytes -> Either Failure Text + 342. Text.gt : Text -> Text -> Boolean + 343. Text.gteq : Text -> Text -> Boolean + 344. Text.lt : Text -> Text -> Boolean + 345. Text.lteq : Text -> Text -> Boolean + 346. Text.repeat : Nat -> Text -> Text + 347. Text.size : Text -> Nat + 348. Text.take : Nat -> Text -> Text + 349. Text.toCharList : Text -> [Char] + 350. Text.toUtf8 : Text -> Bytes + 351. Text.uncons : Text -> Optional (Char, Text) + 352. Text.unsnoc : Text -> Optional (Text, Char) + 353. todo : a -> b + 354. structural type Tuple a b + 355. Tuple.Cons : a -> b -> Tuple a b + 356. structural type Unit + 357. Unit.Unit : () + 358. Universal.< : a -> a -> Boolean + 359. Universal.<= : a -> a -> Boolean + 360. Universal.== : a -> a -> Boolean + 361. Universal.> : a -> a -> Boolean + 362. Universal.>= : a -> a -> Boolean + 363. Universal.compare : a -> a -> Int + 364. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 365. builtin type Value + 366. Value.dependencies : Value -> [Term] + 367. Value.deserialize : Bytes -> Either Text Value + 368. Value.load : Value ->{IO} Either [Term] a + 369. Value.serialize : Value -> Bytes + 370. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -464,17 +466,17 @@ Let's try it! Added definitions: - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.gt : Float -> Float -> Boolean + 2. Float.gteq : Float -> Float -> Boolean + 3. Float.log : Float -> Float + 4. Float.logBase : Float -> Float -> Float + 5. Float.lt : Float -> Float -> Boolean + 6. Float.lteq : Float -> Float -> Boolean + 7. Float.max : Float -> Float -> Float + 8. Float.min : Float -> Float -> Float + 9. Float.pow : Float -> Float -> Float + 10. Float.round : Float -> Int + 11. Float.sin : Float -> Float Tip: You can use `undo` or `reflog` to undo this change. @@ -534,17 +536,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.gt : Float -> Float -> Boolean + 2. Float.gteq : Float -> Float -> Boolean + 3. Float.log : Float -> Float + 4. Float.logBase : Float -> Float -> Float + 5. Float.lt : Float -> Float -> Boolean + 6. Float.lteq : Float -> Float -> Boolean + 7. Float.max : Float -> Float -> Float + 8. Float.min : Float -> Float -> Float + 9. Float.pow : Float -> Float -> Float + 10. Float.round : Float -> Int + 11. Float.sin : Float -> Float 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index c7410c7aa4..1a86c24a46 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -35,7 +35,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 24. IsTest (type) 25. IsTest/ (1 definition) 26. Link (type) - 27. Link/ (4 definitions) + 27. Link/ (5 definitions) 28. List (builtin type) 29. List/ (10 definitions) 30. Nat (builtin type) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index d427631348..f02fea7be8 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (368 definitions) + 1. builtin/ (369 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (536 definitions) + 1. builtin/ (537 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 0800365338..d1fa5cfb1d 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #nl3sdb3eid + ⊙ #70d068se1n - Deletes: feature1.y - ⊙ #nt4hpgmam9 + ⊙ #b38gm3a91g + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #hjtrj2kgl4 + ⊙ #2mafeu0qi9 + Adds / updates: feature1.y - ⊙ #04vktkvglu + ⊙ #o0i3gspbka > Moves: Original name New name x master.x - ⊙ #0g638hmb59 + ⊙ #impsqkntjo + Adds / updates: x - □ #2f9h2uhlk9 (start of history) + □ #8eh9l1p8vo (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index c4afd9df17..daa939ae9b 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #3n9h2vkhe3 .old` to make an old namespace + `fork #chv8uql7m1 .old` to make an old namespace accessible again, - `reset-root #3n9h2vkhe3` to reset the root namespace and + `reset-root #chv8uql7m1` to reset the root namespace and its history to that of the specified namespace. - 1. #vfl0sjr6kg : add - 2. #3n9h2vkhe3 : add - 3. #2f9h2uhlk9 : builtins.merge + 1. #c7p2o500b5 : add + 2. #chv8uql7m1 : add + 3. #8eh9l1p8vo : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index b81f736d35..85ecdf60dc 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #7ms46v3pba > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #2gpohro3j9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #7ms46v3pba > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #2gpohro3j9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #jqps95msh5 + ⊙ #pd0uqrl239 - Deletes: Nat.* Nat.+ - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 2decef34abca63f4b76784cf8176ae6284fdc8b6 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Fri, 10 Sep 2021 11:48:52 -0700 Subject: [PATCH 073/148] missed one? --- unison-src/transcripts/alias-many.output.md | 779 ++++++++++---------- 1 file changed, 389 insertions(+), 390 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 668d38d477..ec7f83540e 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -20,444 +20,443 @@ Let's try it! 1. builtin type Any 2. Any.Any : a -> Any - 3. Any.unsafeExtract : Any -> a - 4. builtin type Boolean - 5. Boolean.not : Boolean -> Boolean - 6. bug : a -> b - 7. builtin type Bytes - 8. Bytes.++ : Bytes -> Bytes -> Bytes - 9. Bytes.at : Nat -> Bytes -> Optional Nat - 10. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) - 11. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) - 12. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) - 13. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) - 14. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) - 15. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) - 16. Bytes.drop : Nat -> Bytes -> Bytes - 17. Bytes.empty : Bytes - 18. Bytes.encodeNat16be : Nat -> Bytes - 19. Bytes.encodeNat16le : Nat -> Bytes - 20. Bytes.encodeNat32be : Nat -> Bytes - 21. Bytes.encodeNat32le : Nat -> Bytes - 22. Bytes.encodeNat64be : Nat -> Bytes - 23. Bytes.encodeNat64le : Nat -> Bytes - 24. Bytes.flatten : Bytes -> Bytes - 25. Bytes.fromBase16 : Bytes -> Either Text Bytes - 26. Bytes.fromBase32 : Bytes -> Either Text Bytes - 27. Bytes.fromBase64 : Bytes -> Either Text Bytes - 28. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 29. Bytes.fromList : [Nat] -> Bytes - 30. Bytes.size : Bytes -> Nat - 31. Bytes.take : Nat -> Bytes -> Bytes - 32. Bytes.toBase16 : Bytes -> Bytes - 33. Bytes.toBase32 : Bytes -> Bytes - 34. Bytes.toBase64 : Bytes -> Bytes - 35. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 36. Bytes.toList : Bytes -> [Nat] - 37. builtin type Char - 38. Char.fromNat : Nat -> Char - 39. Char.toNat : Char -> Nat - 40. Char.toText : Char -> Text - 41. builtin type Code - 42. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 43. Code.dependencies : Code -> [Term] - 44. Code.deserialize : Bytes -> Either Text Code - 45. Code.isMissing : Term ->{IO} Boolean - 46. Code.lookup : Term ->{IO} Optional Code - 47. Code.serialize : Code -> Bytes - 48. crypto.hash : HashAlgorithm -> a -> Bytes - 49. builtin type crypto.HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 52. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 56. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 57. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 58. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 59. crypto.hmacBytes : HashAlgorithm + 3. builtin type Boolean + 4. Boolean.not : Boolean -> Boolean + 5. bug : a -> b + 6. builtin type Bytes + 7. Bytes.++ : Bytes -> Bytes -> Bytes + 8. Bytes.at : Nat -> Bytes -> Optional Nat + 9. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) + 10. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) + 11. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) + 12. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) + 13. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) + 14. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) + 15. Bytes.drop : Nat -> Bytes -> Bytes + 16. Bytes.empty : Bytes + 17. Bytes.encodeNat16be : Nat -> Bytes + 18. Bytes.encodeNat16le : Nat -> Bytes + 19. Bytes.encodeNat32be : Nat -> Bytes + 20. Bytes.encodeNat32le : Nat -> Bytes + 21. Bytes.encodeNat64be : Nat -> Bytes + 22. Bytes.encodeNat64le : Nat -> Bytes + 23. Bytes.flatten : Bytes -> Bytes + 24. Bytes.fromBase16 : Bytes -> Either Text Bytes + 25. Bytes.fromBase32 : Bytes -> Either Text Bytes + 26. Bytes.fromBase64 : Bytes -> Either Text Bytes + 27. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes + 28. Bytes.fromList : [Nat] -> Bytes + 29. Bytes.size : Bytes -> Nat + 30. Bytes.take : Nat -> Bytes -> Bytes + 31. Bytes.toBase16 : Bytes -> Bytes + 32. Bytes.toBase32 : Bytes -> Bytes + 33. Bytes.toBase64 : Bytes -> Bytes + 34. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 35. Bytes.toList : Bytes -> [Nat] + 36. builtin type Char + 37. Char.fromNat : Nat -> Char + 38. Char.toNat : Char -> Nat + 39. Char.toText : Char -> Text + 40. builtin type Code + 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 42. Code.dependencies : Code -> [Term] + 43. Code.deserialize : Bytes -> Either Text Code + 44. Code.isMissing : Term ->{IO} Boolean + 45. Code.lookup : Term ->{IO} Optional Code + 46. Code.serialize : Code -> Bytes + 47. crypto.hash : HashAlgorithm -> a -> Bytes + 48. builtin type crypto.HashAlgorithm + 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 58. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 60. Debug.watch : Text -> a -> a - 61. unique type Doc - 62. Doc.Blob : Text -> Doc - 63. Doc.Evaluate : Term -> Doc - 64. Doc.Join : [Doc] -> Doc - 65. Doc.Link : Link -> Doc - 66. Doc.Signature : Term -> Doc - 67. Doc.Source : Link -> Doc - 68. structural type Either a b - 69. Either.Left : a -> Either a b - 70. Either.Right : b -> Either a b - 71. structural ability Exception - 72. Exception.raise : Failure ->{Exception} x - 73. builtin type Float - 74. Float.* : Float -> Float -> Float - 75. Float.+ : Float -> Float -> Float - 76. Float.- : Float -> Float -> Float - 77. Float./ : Float -> Float -> Float - 78. Float.abs : Float -> Float - 79. Float.acos : Float -> Float - 80. Float.acosh : Float -> Float - 81. Float.asin : Float -> Float - 82. Float.asinh : Float -> Float - 83. Float.atan : Float -> Float - 84. Float.atan2 : Float -> Float -> Float - 85. Float.atanh : Float -> Float - 86. Float.ceiling : Float -> Int - 87. Float.cos : Float -> Float - 88. Float.cosh : Float -> Float - 89. Float.eq : Float -> Float -> Boolean - 90. Float.exp : Float -> Float - 91. Float.floor : Float -> Int - 92. Float.fromRepresentation : Nat -> Float - 93. Float.fromText : Text -> Optional Float - 94. Float.gt : Float -> Float -> Boolean - 95. Float.gteq : Float -> Float -> Boolean - 96. Float.log : Float -> Float - 97. Float.logBase : Float -> Float -> Float - 98. Float.lt : Float -> Float -> Boolean - 99. Float.lteq : Float -> Float -> Boolean - 100. Float.max : Float -> Float -> Float - 101. Float.min : Float -> Float -> Float - 102. Float.pow : Float -> Float -> Float - 103. Float.round : Float -> Int - 104. Float.sin : Float -> Float - 105. Float.sinh : Float -> Float - 106. Float.sqrt : Float -> Float - 107. Float.tan : Float -> Float - 108. Float.tanh : Float -> Float - 109. Float.toRepresentation : Float -> Nat - 110. Float.toText : Float -> Text - 111. Float.truncate : Float -> Int - 112. builtin type Int - 113. Int.* : Int -> Int -> Int - 114. Int.+ : Int -> Int -> Int - 115. Int.- : Int -> Int -> Int - 116. Int./ : Int -> Int -> Int - 117. Int.and : Int -> Int -> Int - 118. Int.complement : Int -> Int - 119. Int.eq : Int -> Int -> Boolean - 120. Int.fromRepresentation : Nat -> Int - 121. Int.fromText : Text -> Optional Int - 122. Int.gt : Int -> Int -> Boolean - 123. Int.gteq : Int -> Int -> Boolean - 124. Int.increment : Int -> Int - 125. Int.isEven : Int -> Boolean - 126. Int.isOdd : Int -> Boolean - 127. Int.leadingZeros : Int -> Nat - 128. Int.lt : Int -> Int -> Boolean - 129. Int.lteq : Int -> Int -> Boolean - 130. Int.mod : Int -> Int -> Int - 131. Int.negate : Int -> Int - 132. Int.or : Int -> Int -> Int - 133. Int.popCount : Int -> Nat - 134. Int.pow : Int -> Nat -> Int - 135. Int.shiftLeft : Int -> Nat -> Int - 136. Int.shiftRight : Int -> Nat -> Int - 137. Int.signum : Int -> Int - 138. Int.toFloat : Int -> Float - 139. Int.toRepresentation : Int -> Nat - 140. Int.toText : Int -> Text - 141. Int.trailingZeros : Int -> Nat - 142. Int.truncate0 : Int -> Nat - 143. Int.xor : Int -> Int -> Int - 144. unique type io2.BufferMode - 145. io2.BufferMode.BlockBuffering : BufferMode - 146. io2.BufferMode.LineBuffering : BufferMode - 147. io2.BufferMode.NoBuffering : BufferMode - 148. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 149. unique type io2.Failure - 150. io2.Failure.Failure : Type -> Text -> Any -> Failure - 151. unique type io2.FileMode - 152. io2.FileMode.Append : FileMode - 153. io2.FileMode.Read : FileMode - 154. io2.FileMode.ReadWrite : FileMode - 155. io2.FileMode.Write : FileMode - 156. builtin type io2.Handle - 157. builtin type io2.IO - 158. io2.IO.clientSocket.impl : Text + 59. Debug.watch : Text -> a -> a + 60. unique type Doc + 61. Doc.Blob : Text -> Doc + 62. Doc.Evaluate : Term -> Doc + 63. Doc.Join : [Doc] -> Doc + 64. Doc.Link : Link -> Doc + 65. Doc.Signature : Term -> Doc + 66. Doc.Source : Link -> Doc + 67. structural type Either a b + 68. Either.Left : a -> Either a b + 69. Either.Right : b -> Either a b + 70. structural ability Exception + 71. Exception.raise : Failure ->{Exception} x + 72. builtin type Float + 73. Float.* : Float -> Float -> Float + 74. Float.+ : Float -> Float -> Float + 75. Float.- : Float -> Float -> Float + 76. Float./ : Float -> Float -> Float + 77. Float.abs : Float -> Float + 78. Float.acos : Float -> Float + 79. Float.acosh : Float -> Float + 80. Float.asin : Float -> Float + 81. Float.asinh : Float -> Float + 82. Float.atan : Float -> Float + 83. Float.atan2 : Float -> Float -> Float + 84. Float.atanh : Float -> Float + 85. Float.ceiling : Float -> Int + 86. Float.cos : Float -> Float + 87. Float.cosh : Float -> Float + 88. Float.eq : Float -> Float -> Boolean + 89. Float.exp : Float -> Float + 90. Float.floor : Float -> Int + 91. Float.fromRepresentation : Nat -> Float + 92. Float.fromText : Text -> Optional Float + 93. Float.gt : Float -> Float -> Boolean + 94. Float.gteq : Float -> Float -> Boolean + 95. Float.log : Float -> Float + 96. Float.logBase : Float -> Float -> Float + 97. Float.lt : Float -> Float -> Boolean + 98. Float.lteq : Float -> Float -> Boolean + 99. Float.max : Float -> Float -> Float + 100. Float.min : Float -> Float -> Float + 101. Float.pow : Float -> Float -> Float + 102. Float.round : Float -> Int + 103. Float.sin : Float -> Float + 104. Float.sinh : Float -> Float + 105. Float.sqrt : Float -> Float + 106. Float.tan : Float -> Float + 107. Float.tanh : Float -> Float + 108. Float.toRepresentation : Float -> Nat + 109. Float.toText : Float -> Text + 110. Float.truncate : Float -> Int + 111. builtin type Int + 112. Int.* : Int -> Int -> Int + 113. Int.+ : Int -> Int -> Int + 114. Int.- : Int -> Int -> Int + 115. Int./ : Int -> Int -> Int + 116. Int.and : Int -> Int -> Int + 117. Int.complement : Int -> Int + 118. Int.eq : Int -> Int -> Boolean + 119. Int.fromRepresentation : Nat -> Int + 120. Int.fromText : Text -> Optional Int + 121. Int.gt : Int -> Int -> Boolean + 122. Int.gteq : Int -> Int -> Boolean + 123. Int.increment : Int -> Int + 124. Int.isEven : Int -> Boolean + 125. Int.isOdd : Int -> Boolean + 126. Int.leadingZeros : Int -> Nat + 127. Int.lt : Int -> Int -> Boolean + 128. Int.lteq : Int -> Int -> Boolean + 129. Int.mod : Int -> Int -> Int + 130. Int.negate : Int -> Int + 131. Int.or : Int -> Int -> Int + 132. Int.popCount : Int -> Nat + 133. Int.pow : Int -> Nat -> Int + 134. Int.shiftLeft : Int -> Nat -> Int + 135. Int.shiftRight : Int -> Nat -> Int + 136. Int.signum : Int -> Int + 137. Int.toFloat : Int -> Float + 138. Int.toRepresentation : Int -> Nat + 139. Int.toText : Int -> Text + 140. Int.trailingZeros : Int -> Nat + 141. Int.truncate0 : Int -> Nat + 142. Int.xor : Int -> Int -> Int + 143. unique type io2.BufferMode + 144. io2.BufferMode.BlockBuffering : BufferMode + 145. io2.BufferMode.LineBuffering : BufferMode + 146. io2.BufferMode.NoBuffering : BufferMode + 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 148. unique type io2.Failure + 149. io2.Failure.Failure : Type -> Text -> Any -> Failure + 150. unique type io2.FileMode + 151. io2.FileMode.Append : FileMode + 152. io2.FileMode.Read : FileMode + 153. io2.FileMode.ReadWrite : FileMode + 154. io2.FileMode.Write : FileMode + 155. builtin type io2.Handle + 156. builtin type io2.IO + 157. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 159. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 160. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 161. io2.IO.createDirectory.impl : Text + 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 160. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 162. io2.IO.createTempDirectory.impl : Text + 161. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 163. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 164. io2.IO.directoryContents.impl : Text + 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 163. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 165. io2.IO.fileExists.impl : Text + 164. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 166. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 167. io2.IO.getBuffering.impl : Handle + 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 166. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 168. io2.IO.getBytes.impl : Handle + 167. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 169. io2.IO.getCurrentDirectory.impl : '{IO} Either + 168. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 170. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 171. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getFileTimestamp.impl : Text + 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 171. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 173. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 174. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 175. io2.IO.handlePosition.impl : Handle + 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 174. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 176. io2.IO.isDirectory.impl : Text + 175. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 177. io2.IO.isFileEOF.impl : Handle + 176. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isFileOpen.impl : Handle + 177. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.isSeekable.impl : Handle + 178. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 180. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 181. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 182. io2.IO.openFile.impl : Text + 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 181. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 183. io2.IO.putBytes.impl : Handle + 182. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 184. io2.IO.ref : a ->{IO} Ref {IO} a - 185. io2.IO.removeDirectory.impl : Text + 183. io2.IO.ref : a ->{IO} Ref {IO} a + 184. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 186. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 187. io2.IO.renameDirectory.impl : Text + 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 186. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 188. io2.IO.renameFile.impl : Text + 187. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 189. io2.IO.seekHandle.impl : Handle + 188. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 190. io2.IO.serverSocket.impl : Optional Text + 189. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 191. io2.IO.setBuffering.impl : Handle + 190. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 192. io2.IO.setCurrentDirectory.impl : Text + 191. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 193. io2.IO.socketAccept.impl : Socket + 192. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 194. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 195. io2.IO.socketReceive.impl : Socket + 193. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 194. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 196. io2.IO.socketSend.impl : Socket + 195. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 197. io2.IO.stdHandle : StdHandle -> Handle - 198. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 199. unique type io2.IOError - 200. io2.IOError.AlreadyExists : IOError - 201. io2.IOError.EOF : IOError - 202. io2.IOError.IllegalOperation : IOError - 203. io2.IOError.NoSuchThing : IOError - 204. io2.IOError.PermissionDenied : IOError - 205. io2.IOError.ResourceBusy : IOError - 206. io2.IOError.ResourceExhausted : IOError - 207. io2.IOError.UserError : IOError - 208. unique type io2.IOFailure - 209. builtin type io2.MVar - 210. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 211. io2.MVar.new : a ->{IO} MVar a - 212. io2.MVar.newEmpty : '{IO} MVar a - 213. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 214. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 215. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 216. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 217. io2.MVar.tryPut.impl : MVar a + 196. io2.IO.stdHandle : StdHandle -> Handle + 197. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 198. unique type io2.IOError + 199. io2.IOError.AlreadyExists : IOError + 200. io2.IOError.EOF : IOError + 201. io2.IOError.IllegalOperation : IOError + 202. io2.IOError.NoSuchThing : IOError + 203. io2.IOError.PermissionDenied : IOError + 204. io2.IOError.ResourceBusy : IOError + 205. io2.IOError.ResourceExhausted : IOError + 206. io2.IOError.UserError : IOError + 207. unique type io2.IOFailure + 208. builtin type io2.MVar + 209. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 210. io2.MVar.new : a ->{IO} MVar a + 211. io2.MVar.newEmpty : '{IO} MVar a + 212. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 213. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 214. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 215. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 216. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 218. io2.MVar.tryRead.impl : MVar a + 217. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 219. io2.MVar.tryTake : MVar a ->{IO} Optional a - 220. unique type io2.SeekMode - 221. io2.SeekMode.AbsoluteSeek : SeekMode - 222. io2.SeekMode.RelativeSeek : SeekMode - 223. io2.SeekMode.SeekFromEnd : SeekMode - 224. builtin type io2.Socket - 225. unique type io2.StdHandle - 226. io2.StdHandle.StdErr : StdHandle - 227. io2.StdHandle.StdIn : StdHandle - 228. io2.StdHandle.StdOut : StdHandle - 229. builtin type io2.STM - 230. io2.STM.atomically : '{STM} a ->{IO} a - 231. io2.STM.retry : '{STM} a - 232. builtin type io2.ThreadId - 233. builtin type io2.Tls - 234. builtin type io2.Tls.Cipher - 235. builtin type io2.Tls.ClientConfig - 236. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 218. io2.MVar.tryTake : MVar a ->{IO} Optional a + 219. unique type io2.SeekMode + 220. io2.SeekMode.AbsoluteSeek : SeekMode + 221. io2.SeekMode.RelativeSeek : SeekMode + 222. io2.SeekMode.SeekFromEnd : SeekMode + 223. builtin type io2.Socket + 224. unique type io2.StdHandle + 225. io2.StdHandle.StdErr : StdHandle + 226. io2.StdHandle.StdIn : StdHandle + 227. io2.StdHandle.StdOut : StdHandle + 228. builtin type io2.STM + 229. io2.STM.atomically : '{STM} a ->{IO} a + 230. io2.STM.retry : '{STM} a + 231. builtin type io2.ThreadId + 232. builtin type io2.Tls + 233. builtin type io2.Tls.Cipher + 234. builtin type io2.Tls.ClientConfig + 235. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 237. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 236. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 238. io2.Tls.ClientConfig.default : Text + 237. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 239. io2.Tls.ClientConfig.versions.set : [Version] + 238. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 240. io2.Tls.decodeCert.impl : Bytes + 239. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 241. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 242. io2.Tls.encodeCert : SignedCert -> Bytes - 243. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 244. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 245. io2.Tls.newClient.impl : ClientConfig + 240. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 241. io2.Tls.encodeCert : SignedCert -> Bytes + 242. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 243. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 244. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 246. io2.Tls.newServer.impl : ServerConfig + 245. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 247. builtin type io2.Tls.PrivateKey - 248. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 249. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 250. builtin type io2.Tls.ServerConfig - 251. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 246. builtin type io2.Tls.PrivateKey + 247. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 248. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 249. builtin type io2.Tls.ServerConfig + 250. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 252. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 251. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 253. io2.Tls.ServerConfig.default : [SignedCert] + 252. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 254. io2.Tls.ServerConfig.versions.set : [Version] + 253. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 255. builtin type io2.Tls.SignedCert - 256. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 257. builtin type io2.Tls.Version - 258. unique type io2.TlsFailure - 259. builtin type io2.TVar - 260. io2.TVar.new : a ->{STM} TVar a - 261. io2.TVar.newIO : a ->{IO} TVar a - 262. io2.TVar.read : TVar a ->{STM} a - 263. io2.TVar.readIO : TVar a ->{IO} a - 264. io2.TVar.swap : TVar a -> a ->{STM} a - 265. io2.TVar.write : TVar a -> a ->{STM} () - 266. unique type IsPropagated - 267. IsPropagated.IsPropagated : IsPropagated - 268. unique type IsTest - 269. IsTest.IsTest : IsTest - 270. unique type Link - 271. builtin type Link.Term - 272. Link.Term : Term -> Link - 273. Link.Term.toText : Term -> Text - 274. builtin type Link.Type - 275. Link.Type : Type -> Link - 276. builtin type List - 277. List.++ : [a] -> [a] -> [a] - 278. List.+: : a -> [a] -> [a] - 279. List.:+ : [a] -> a -> [a] - 280. List.at : Nat -> [a] -> Optional a - 281. List.cons : a -> [a] -> [a] - 282. List.drop : Nat -> [a] -> [a] - 283. List.empty : [a] - 284. List.size : [a] -> Nat - 285. List.snoc : [a] -> a -> [a] - 286. List.take : Nat -> [a] -> [a] - 287. metadata.isPropagated : IsPropagated - 288. metadata.isTest : IsTest - 289. builtin type Nat - 290. Nat.* : Nat -> Nat -> Nat - 291. Nat.+ : Nat -> Nat -> Nat - 292. Nat./ : Nat -> Nat -> Nat - 293. Nat.and : Nat -> Nat -> Nat - 294. Nat.complement : Nat -> Nat - 295. Nat.drop : Nat -> Nat -> Nat - 296. Nat.eq : Nat -> Nat -> Boolean - 297. Nat.fromText : Text -> Optional Nat - 298. Nat.gt : Nat -> Nat -> Boolean - 299. Nat.gteq : Nat -> Nat -> Boolean - 300. Nat.increment : Nat -> Nat - 301. Nat.isEven : Nat -> Boolean - 302. Nat.isOdd : Nat -> Boolean - 303. Nat.leadingZeros : Nat -> Nat - 304. Nat.lt : Nat -> Nat -> Boolean - 305. Nat.lteq : Nat -> Nat -> Boolean - 306. Nat.mod : Nat -> Nat -> Nat - 307. Nat.or : Nat -> Nat -> Nat - 308. Nat.popCount : Nat -> Nat - 309. Nat.pow : Nat -> Nat -> Nat - 310. Nat.shiftLeft : Nat -> Nat -> Nat - 311. Nat.shiftRight : Nat -> Nat -> Nat - 312. Nat.sub : Nat -> Nat -> Int - 313. Nat.toFloat : Nat -> Float - 314. Nat.toInt : Nat -> Int - 315. Nat.toText : Nat -> Text - 316. Nat.trailingZeros : Nat -> Nat - 317. Nat.xor : Nat -> Nat -> Nat - 318. structural type Optional a - 319. Optional.None : Optional a - 320. Optional.Some : a -> Optional a - 321. builtin type Ref - 322. Ref.read : Ref g a ->{g} a - 323. Ref.write : Ref g a -> a ->{g} () - 324. builtin type Request - 325. builtin type Scope - 326. Scope.ref : a ->{Scope s} Ref {Scope s} a - 327. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 328. structural type SeqView a b - 329. SeqView.VElem : a -> b -> SeqView a b - 330. SeqView.VEmpty : SeqView a b - 331. unique type Test.Result - 332. Test.Result.Fail : Text -> Result - 333. Test.Result.Ok : Text -> Result - 334. builtin type Text - 335. Text.!= : Text -> Text -> Boolean - 336. Text.++ : Text -> Text -> Text - 337. Text.drop : Nat -> Text -> Text - 338. Text.empty : Text - 339. Text.eq : Text -> Text -> Boolean - 340. Text.fromCharList : [Char] -> Text - 341. Text.fromUtf8.impl : Bytes -> Either Failure Text - 342. Text.gt : Text -> Text -> Boolean - 343. Text.gteq : Text -> Text -> Boolean - 344. Text.lt : Text -> Text -> Boolean - 345. Text.lteq : Text -> Text -> Boolean - 346. Text.repeat : Nat -> Text -> Text - 347. Text.size : Text -> Nat - 348. Text.take : Nat -> Text -> Text - 349. Text.toCharList : Text -> [Char] - 350. Text.toUtf8 : Text -> Bytes - 351. Text.uncons : Text -> Optional (Char, Text) - 352. Text.unsnoc : Text -> Optional (Text, Char) - 353. todo : a -> b - 354. structural type Tuple a b - 355. Tuple.Cons : a -> b -> Tuple a b - 356. structural type Unit - 357. Unit.Unit : () - 358. Universal.< : a -> a -> Boolean - 359. Universal.<= : a -> a -> Boolean - 360. Universal.== : a -> a -> Boolean - 361. Universal.> : a -> a -> Boolean - 362. Universal.>= : a -> a -> Boolean - 363. Universal.compare : a -> a -> Int - 364. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 365. builtin type Value - 366. Value.dependencies : Value -> [Term] - 367. Value.deserialize : Bytes -> Either Text Value - 368. Value.load : Value ->{IO} Either [Term] a - 369. Value.serialize : Value -> Bytes - 370. Value.value : a -> Value + 254. builtin type io2.Tls.SignedCert + 255. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 256. builtin type io2.Tls.Version + 257. unique type io2.TlsFailure + 258. builtin type io2.TVar + 259. io2.TVar.new : a ->{STM} TVar a + 260. io2.TVar.newIO : a ->{IO} TVar a + 261. io2.TVar.read : TVar a ->{STM} a + 262. io2.TVar.readIO : TVar a ->{IO} a + 263. io2.TVar.swap : TVar a -> a ->{STM} a + 264. io2.TVar.write : TVar a -> a ->{STM} () + 265. unique type IsPropagated + 266. IsPropagated.IsPropagated : IsPropagated + 267. unique type IsTest + 268. IsTest.IsTest : IsTest + 269. unique type Link + 270. builtin type Link.Term + 271. Link.Term : Term -> Link + 272. Link.Term.toText : Term -> Text + 273. builtin type Link.Type + 274. Link.Type : Type -> Link + 275. builtin type List + 276. List.++ : [a] -> [a] -> [a] + 277. List.+: : a -> [a] -> [a] + 278. List.:+ : [a] -> a -> [a] + 279. List.at : Nat -> [a] -> Optional a + 280. List.cons : a -> [a] -> [a] + 281. List.drop : Nat -> [a] -> [a] + 282. List.empty : [a] + 283. List.size : [a] -> Nat + 284. List.snoc : [a] -> a -> [a] + 285. List.take : Nat -> [a] -> [a] + 286. metadata.isPropagated : IsPropagated + 287. metadata.isTest : IsTest + 288. builtin type Nat + 289. Nat.* : Nat -> Nat -> Nat + 290. Nat.+ : Nat -> Nat -> Nat + 291. Nat./ : Nat -> Nat -> Nat + 292. Nat.and : Nat -> Nat -> Nat + 293. Nat.complement : Nat -> Nat + 294. Nat.drop : Nat -> Nat -> Nat + 295. Nat.eq : Nat -> Nat -> Boolean + 296. Nat.fromText : Text -> Optional Nat + 297. Nat.gt : Nat -> Nat -> Boolean + 298. Nat.gteq : Nat -> Nat -> Boolean + 299. Nat.increment : Nat -> Nat + 300. Nat.isEven : Nat -> Boolean + 301. Nat.isOdd : Nat -> Boolean + 302. Nat.leadingZeros : Nat -> Nat + 303. Nat.lt : Nat -> Nat -> Boolean + 304. Nat.lteq : Nat -> Nat -> Boolean + 305. Nat.mod : Nat -> Nat -> Nat + 306. Nat.or : Nat -> Nat -> Nat + 307. Nat.popCount : Nat -> Nat + 308. Nat.pow : Nat -> Nat -> Nat + 309. Nat.shiftLeft : Nat -> Nat -> Nat + 310. Nat.shiftRight : Nat -> Nat -> Nat + 311. Nat.sub : Nat -> Nat -> Int + 312. Nat.toFloat : Nat -> Float + 313. Nat.toInt : Nat -> Int + 314. Nat.toText : Nat -> Text + 315. Nat.trailingZeros : Nat -> Nat + 316. Nat.xor : Nat -> Nat -> Nat + 317. structural type Optional a + 318. Optional.None : Optional a + 319. Optional.Some : a -> Optional a + 320. builtin type Ref + 321. Ref.read : Ref g a ->{g} a + 322. Ref.write : Ref g a -> a ->{g} () + 323. builtin type Request + 324. builtin type Scope + 325. Scope.ref : a ->{Scope s} Ref {Scope s} a + 326. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 327. structural type SeqView a b + 328. SeqView.VElem : a -> b -> SeqView a b + 329. SeqView.VEmpty : SeqView a b + 330. unique type Test.Result + 331. Test.Result.Fail : Text -> Result + 332. Test.Result.Ok : Text -> Result + 333. builtin type Text + 334. Text.!= : Text -> Text -> Boolean + 335. Text.++ : Text -> Text -> Text + 336. Text.drop : Nat -> Text -> Text + 337. Text.empty : Text + 338. Text.eq : Text -> Text -> Boolean + 339. Text.fromCharList : [Char] -> Text + 340. Text.fromUtf8.impl : Bytes -> Either Failure Text + 341. Text.gt : Text -> Text -> Boolean + 342. Text.gteq : Text -> Text -> Boolean + 343. Text.lt : Text -> Text -> Boolean + 344. Text.lteq : Text -> Text -> Boolean + 345. Text.repeat : Nat -> Text -> Text + 346. Text.size : Text -> Nat + 347. Text.take : Nat -> Text -> Text + 348. Text.toCharList : Text -> [Char] + 349. Text.toUtf8 : Text -> Bytes + 350. Text.uncons : Text -> Optional (Char, Text) + 351. Text.unsnoc : Text -> Optional (Text, Char) + 352. todo : a -> b + 353. structural type Tuple a b + 354. Tuple.Cons : a -> b -> Tuple a b + 355. structural type Unit + 356. Unit.Unit : () + 357. Universal.< : a -> a -> Boolean + 358. Universal.<= : a -> a -> Boolean + 359. Universal.== : a -> a -> Boolean + 360. Universal.> : a -> a -> Boolean + 361. Universal.>= : a -> a -> Boolean + 362. Universal.compare : a -> a -> Int + 363. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 364. builtin type Value + 365. Value.dependencies : Value -> [Term] + 366. Value.deserialize : Bytes -> Either Text Value + 367. Value.load : Value ->{IO} Either [Term] a + 368. Value.serialize : Value -> Bytes + 369. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -466,17 +465,17 @@ Let's try it! Added definitions: - 1. Float.gt : Float -> Float -> Boolean - 2. Float.gteq : Float -> Float -> Boolean - 3. Float.log : Float -> Float - 4. Float.logBase : Float -> Float -> Float - 5. Float.lt : Float -> Float -> Boolean - 6. Float.lteq : Float -> Float -> Boolean - 7. Float.max : Float -> Float -> Float - 8. Float.min : Float -> Float -> Float - 9. Float.pow : Float -> Float -> Float - 10. Float.round : Float -> Int - 11. Float.sin : Float -> Float + 1. Float.gteq : Float -> Float -> Boolean + 2. Float.log : Float -> Float + 3. Float.logBase : Float -> Float -> Float + 4. Float.lt : Float -> Float -> Boolean + 5. Float.lteq : Float -> Float -> Boolean + 6. Float.max : Float -> Float -> Float + 7. Float.min : Float -> Float -> Float + 8. Float.pow : Float -> Float -> Float + 9. Float.round : Float -> Int + 10. Float.sin : Float -> Float + 11. Float.sinh : Float -> Float Tip: You can use `undo` or `reflog` to undo this change. @@ -536,17 +535,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.gt : Float -> Float -> Boolean - 2. Float.gteq : Float -> Float -> Boolean - 3. Float.log : Float -> Float - 4. Float.logBase : Float -> Float -> Float - 5. Float.lt : Float -> Float -> Boolean - 6. Float.lteq : Float -> Float -> Boolean - 7. Float.max : Float -> Float -> Float - 8. Float.min : Float -> Float -> Float - 9. Float.pow : Float -> Float -> Float - 10. Float.round : Float -> Int - 11. Float.sin : Float -> Float + 1. Float.gteq : Float -> Float -> Boolean + 2. Float.log : Float -> Float + 3. Float.logBase : Float -> Float -> Float + 4. Float.lt : Float -> Float -> Boolean + 5. Float.lteq : Float -> Float -> Boolean + 6. Float.max : Float -> Float -> Float + 7. Float.min : Float -> Float -> Float + 8. Float.pow : Float -> Float -> Float + 9. Float.round : Float -> Int + 10. Float.sin : Float -> Float + 11. Float.sinh : Float -> Float 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean From 53a9a4650b09d060ebbf86a23442384de1e94773 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 10 Sep 2021 15:26:49 -0400 Subject: [PATCH 074/148] Fix linebreaking in long binary op chains --- parser-typechecker/src/Unison/TermPrinter.hs | 28 ++++--- unison-src/transcripts-round-trip/main.md | 22 ++++++ .../transcripts-round-trip/main.output.md | 79 +++++++++++++++++++ .../transcripts/bug-strange-closure.output.md | 7 +- 4 files changed, 121 insertions(+), 15 deletions(-) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 1687a7083d..e79a45c65b 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -406,21 +406,27 @@ pretty0 -- produce any backticks. We build the result out from the right, -- starting at `f2`. binaryApps - :: Var v => [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] - -> Pretty SyntaxText - -> Pretty SyntaxText + :: Var v + => [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] + -> Pretty SyntaxText + -> Pretty SyntaxText binaryApps xs last = unbroken `PP.orElse` broken - -- todo: use `PP.column2` in the case where we need to break where unbroken = PP.spaced (ps ++ [last]) - broken = PP.column2 (psCols $ [""] ++ ps ++ [last]) + broken = case take 2 ps of + [x, y] -> PP.hang (x <> " " <> y) . PP.column2 . psCols $ (drop 2 ps ++ [last]) + [] -> last + _ -> undefined psCols ps = case take 2 ps of - [x,y] -> (x,y) : psCols (drop 2 ps) - [] -> [] - _ -> error "??" - ps = join $ [r a f | (a, f) <- reverse xs ] - r a f = [pretty0 n (ac 3 Normal im doc) a, - pretty0 n (AmbientContext 10 Normal Infix im doc False) f] + [x, y] -> (x, y) : psCols (drop 2 ps) + [x] -> [(x, "")] + [] -> [] + _ -> undefined + ps = join $ [ r a f | (a, f) <- reverse xs ] + r a f = + [ pretty0 n (ac 3 Normal im doc) a + , pretty0 n (AmbientContext 10 Normal Infix im doc False) f + ] prettyPattern :: forall v loc . Var v diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index cb4201f918..f8224cb578 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -130,3 +130,25 @@ foo n _ = n ``` ucm .> load scratch.u ``` + +## Long lines with repeated operators + +Regression test for https://github.com/unisonweb/unison/issues/1035 + +```unison:hide +foo : Text +foo = + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddd" +``` + +```ucm +.> add +.> edit foo +.> reflog +.> reset-root 2 +``` + +``` ucm +.> load scratch.u +``` + diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 6e78c69a88..58be640276 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -391,3 +391,82 @@ foo n _ = n foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat ``` +## Long lines with repeated operators + +Regression test for https://github.com/unisonweb/unison/issues/1035 + +```unison +foo : Text +foo = + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddd" +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + foo : Text + +.> edit foo + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + foo : Text + foo = + use Text ++ + "aaaaaaaaaaaaaaaaaaaaaa" ++ + "bbbbbbbbbbbbbbbbbbbbbb" ++ + "cccccccccccccccccccccc" ++ + "dddddddddddddddd" + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> reflog + + Here is a log of the root namespace hashes, starting with the + most recent, along with the command that got us there. Try: + + `fork 2 .old` + `fork #pqvd5behc2 .old` to make an old namespace + accessible again, + + `reset-root #pqvd5behc2` to reset the root namespace and + its history to that of the + specified namespace. + + 1. #2hheevu1j3 : add + 2. #pqvd5behc2 : reset-root #pqvd5behc2 + 3. #j32i1remee : add + 4. #pqvd5behc2 : reset-root #pqvd5behc2 + 5. #acngtb04a8 : add + 6. #pqvd5behc2 : reset-root #pqvd5behc2 + 7. #clsum27pr1 : add + 8. #pqvd5behc2 : reset-root #pqvd5behc2 + 9. #dbvse9969b : add + 10. #pqvd5behc2 : reset-root #pqvd5behc2 + 11. #8rn1an5gj8 : add + 12. #pqvd5behc2 : builtins.mergeio + 13. #sjg2v58vn2 : (initial reflogged namespace) + +.> reset-root 2 + + Done. + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Text + +``` diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md index 8d2aacaabb..e41357a504 100644 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ b/unison-src/transcripts/bug-strange-closure.output.md @@ -2077,10 +2077,9 @@ rendered = Pretty.get (docFormatConsole doc.guide) (Term.Term (Any '(f x -> - f - x - Nat.+ sqr - 1))))), + f x Nat.+ + sqr + 1 ))))), !Lit (Right (Plain "-")), From bcba5e7ac74fe9cb49587a3e8b5a76ce9fed3e64 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Fri, 10 Sep 2021 12:58:02 -0700 Subject: [PATCH 075/148] updated transcripts --- unison-src/transcripts/alias-many.output.md | 195 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 6 files changed, 122 insertions(+), 121 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 5a574d173d..ec7f83540e 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -359,103 +359,104 @@ Let's try it! 269. unique type Link 270. builtin type Link.Term 271. Link.Term : Term -> Link - 272. builtin type Link.Type - 273. Link.Type : Type -> Link - 274. builtin type List - 275. List.++ : [a] -> [a] -> [a] - 276. List.+: : a -> [a] -> [a] - 277. List.:+ : [a] -> a -> [a] - 278. List.at : Nat -> [a] -> Optional a - 279. List.cons : a -> [a] -> [a] - 280. List.drop : Nat -> [a] -> [a] - 281. List.empty : [a] - 282. List.size : [a] -> Nat - 283. List.snoc : [a] -> a -> [a] - 284. List.take : Nat -> [a] -> [a] - 285. metadata.isPropagated : IsPropagated - 286. metadata.isTest : IsTest - 287. builtin type Nat - 288. Nat.* : Nat -> Nat -> Nat - 289. Nat.+ : Nat -> Nat -> Nat - 290. Nat./ : Nat -> Nat -> Nat - 291. Nat.and : Nat -> Nat -> Nat - 292. Nat.complement : Nat -> Nat - 293. Nat.drop : Nat -> Nat -> Nat - 294. Nat.eq : Nat -> Nat -> Boolean - 295. Nat.fromText : Text -> Optional Nat - 296. Nat.gt : Nat -> Nat -> Boolean - 297. Nat.gteq : Nat -> Nat -> Boolean - 298. Nat.increment : Nat -> Nat - 299. Nat.isEven : Nat -> Boolean - 300. Nat.isOdd : Nat -> Boolean - 301. Nat.leadingZeros : Nat -> Nat - 302. Nat.lt : Nat -> Nat -> Boolean - 303. Nat.lteq : Nat -> Nat -> Boolean - 304. Nat.mod : Nat -> Nat -> Nat - 305. Nat.or : Nat -> Nat -> Nat - 306. Nat.popCount : Nat -> Nat - 307. Nat.pow : Nat -> Nat -> Nat - 308. Nat.shiftLeft : Nat -> Nat -> Nat - 309. Nat.shiftRight : Nat -> Nat -> Nat - 310. Nat.sub : Nat -> Nat -> Int - 311. Nat.toFloat : Nat -> Float - 312. Nat.toInt : Nat -> Int - 313. Nat.toText : Nat -> Text - 314. Nat.trailingZeros : Nat -> Nat - 315. Nat.xor : Nat -> Nat -> Nat - 316. structural type Optional a - 317. Optional.None : Optional a - 318. Optional.Some : a -> Optional a - 319. builtin type Ref - 320. Ref.read : Ref g a ->{g} a - 321. Ref.write : Ref g a -> a ->{g} () - 322. builtin type Request - 323. builtin type Scope - 324. Scope.ref : a ->{Scope s} Ref {Scope s} a - 325. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 326. structural type SeqView a b - 327. SeqView.VElem : a -> b -> SeqView a b - 328. SeqView.VEmpty : SeqView a b - 329. unique type Test.Result - 330. Test.Result.Fail : Text -> Result - 331. Test.Result.Ok : Text -> Result - 332. builtin type Text - 333. Text.!= : Text -> Text -> Boolean - 334. Text.++ : Text -> Text -> Text - 335. Text.drop : Nat -> Text -> Text - 336. Text.empty : Text - 337. Text.eq : Text -> Text -> Boolean - 338. Text.fromCharList : [Char] -> Text - 339. Text.fromUtf8.impl : Bytes -> Either Failure Text - 340. Text.gt : Text -> Text -> Boolean - 341. Text.gteq : Text -> Text -> Boolean - 342. Text.lt : Text -> Text -> Boolean - 343. Text.lteq : Text -> Text -> Boolean - 344. Text.repeat : Nat -> Text -> Text - 345. Text.size : Text -> Nat - 346. Text.take : Nat -> Text -> Text - 347. Text.toCharList : Text -> [Char] - 348. Text.toUtf8 : Text -> Bytes - 349. Text.uncons : Text -> Optional (Char, Text) - 350. Text.unsnoc : Text -> Optional (Text, Char) - 351. todo : a -> b - 352. structural type Tuple a b - 353. Tuple.Cons : a -> b -> Tuple a b - 354. structural type Unit - 355. Unit.Unit : () - 356. Universal.< : a -> a -> Boolean - 357. Universal.<= : a -> a -> Boolean - 358. Universal.== : a -> a -> Boolean - 359. Universal.> : a -> a -> Boolean - 360. Universal.>= : a -> a -> Boolean - 361. Universal.compare : a -> a -> Int - 362. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 363. builtin type Value - 364. Value.dependencies : Value -> [Term] - 365. Value.deserialize : Bytes -> Either Text Value - 366. Value.load : Value ->{IO} Either [Term] a - 367. Value.serialize : Value -> Bytes - 368. Value.value : a -> Value + 272. Link.Term.toText : Term -> Text + 273. builtin type Link.Type + 274. Link.Type : Type -> Link + 275. builtin type List + 276. List.++ : [a] -> [a] -> [a] + 277. List.+: : a -> [a] -> [a] + 278. List.:+ : [a] -> a -> [a] + 279. List.at : Nat -> [a] -> Optional a + 280. List.cons : a -> [a] -> [a] + 281. List.drop : Nat -> [a] -> [a] + 282. List.empty : [a] + 283. List.size : [a] -> Nat + 284. List.snoc : [a] -> a -> [a] + 285. List.take : Nat -> [a] -> [a] + 286. metadata.isPropagated : IsPropagated + 287. metadata.isTest : IsTest + 288. builtin type Nat + 289. Nat.* : Nat -> Nat -> Nat + 290. Nat.+ : Nat -> Nat -> Nat + 291. Nat./ : Nat -> Nat -> Nat + 292. Nat.and : Nat -> Nat -> Nat + 293. Nat.complement : Nat -> Nat + 294. Nat.drop : Nat -> Nat -> Nat + 295. Nat.eq : Nat -> Nat -> Boolean + 296. Nat.fromText : Text -> Optional Nat + 297. Nat.gt : Nat -> Nat -> Boolean + 298. Nat.gteq : Nat -> Nat -> Boolean + 299. Nat.increment : Nat -> Nat + 300. Nat.isEven : Nat -> Boolean + 301. Nat.isOdd : Nat -> Boolean + 302. Nat.leadingZeros : Nat -> Nat + 303. Nat.lt : Nat -> Nat -> Boolean + 304. Nat.lteq : Nat -> Nat -> Boolean + 305. Nat.mod : Nat -> Nat -> Nat + 306. Nat.or : Nat -> Nat -> Nat + 307. Nat.popCount : Nat -> Nat + 308. Nat.pow : Nat -> Nat -> Nat + 309. Nat.shiftLeft : Nat -> Nat -> Nat + 310. Nat.shiftRight : Nat -> Nat -> Nat + 311. Nat.sub : Nat -> Nat -> Int + 312. Nat.toFloat : Nat -> Float + 313. Nat.toInt : Nat -> Int + 314. Nat.toText : Nat -> Text + 315. Nat.trailingZeros : Nat -> Nat + 316. Nat.xor : Nat -> Nat -> Nat + 317. structural type Optional a + 318. Optional.None : Optional a + 319. Optional.Some : a -> Optional a + 320. builtin type Ref + 321. Ref.read : Ref g a ->{g} a + 322. Ref.write : Ref g a -> a ->{g} () + 323. builtin type Request + 324. builtin type Scope + 325. Scope.ref : a ->{Scope s} Ref {Scope s} a + 326. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 327. structural type SeqView a b + 328. SeqView.VElem : a -> b -> SeqView a b + 329. SeqView.VEmpty : SeqView a b + 330. unique type Test.Result + 331. Test.Result.Fail : Text -> Result + 332. Test.Result.Ok : Text -> Result + 333. builtin type Text + 334. Text.!= : Text -> Text -> Boolean + 335. Text.++ : Text -> Text -> Text + 336. Text.drop : Nat -> Text -> Text + 337. Text.empty : Text + 338. Text.eq : Text -> Text -> Boolean + 339. Text.fromCharList : [Char] -> Text + 340. Text.fromUtf8.impl : Bytes -> Either Failure Text + 341. Text.gt : Text -> Text -> Boolean + 342. Text.gteq : Text -> Text -> Boolean + 343. Text.lt : Text -> Text -> Boolean + 344. Text.lteq : Text -> Text -> Boolean + 345. Text.repeat : Nat -> Text -> Text + 346. Text.size : Text -> Nat + 347. Text.take : Nat -> Text -> Text + 348. Text.toCharList : Text -> [Char] + 349. Text.toUtf8 : Text -> Bytes + 350. Text.uncons : Text -> Optional (Char, Text) + 351. Text.unsnoc : Text -> Optional (Text, Char) + 352. todo : a -> b + 353. structural type Tuple a b + 354. Tuple.Cons : a -> b -> Tuple a b + 355. structural type Unit + 356. Unit.Unit : () + 357. Universal.< : a -> a -> Boolean + 358. Universal.<= : a -> a -> Boolean + 359. Universal.== : a -> a -> Boolean + 360. Universal.> : a -> a -> Boolean + 361. Universal.>= : a -> a -> Boolean + 362. Universal.compare : a -> a -> Int + 363. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 364. builtin type Value + 365. Value.dependencies : Value -> [Term] + 366. Value.deserialize : Bytes -> Either Text Value + 367. Value.load : Value ->{IO} Either [Term] a + 368. Value.serialize : Value -> Bytes + 369. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index c7410c7aa4..1a86c24a46 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -35,7 +35,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 24. IsTest (type) 25. IsTest/ (1 definition) 26. Link (type) - 27. Link/ (4 definitions) + 27. Link/ (5 definitions) 28. List (builtin type) 29. List/ (10 definitions) 30. Nat (builtin type) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index d427631348..f02fea7be8 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (368 definitions) + 1. builtin/ (369 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (536 definitions) + 1. builtin/ (537 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 0800365338..d1fa5cfb1d 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #nl3sdb3eid + ⊙ #70d068se1n - Deletes: feature1.y - ⊙ #nt4hpgmam9 + ⊙ #b38gm3a91g + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #hjtrj2kgl4 + ⊙ #2mafeu0qi9 + Adds / updates: feature1.y - ⊙ #04vktkvglu + ⊙ #o0i3gspbka > Moves: Original name New name x master.x - ⊙ #0g638hmb59 + ⊙ #impsqkntjo + Adds / updates: x - □ #2f9h2uhlk9 (start of history) + □ #8eh9l1p8vo (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index c4afd9df17..daa939ae9b 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #3n9h2vkhe3 .old` to make an old namespace + `fork #chv8uql7m1 .old` to make an old namespace accessible again, - `reset-root #3n9h2vkhe3` to reset the root namespace and + `reset-root #chv8uql7m1` to reset the root namespace and its history to that of the specified namespace. - 1. #vfl0sjr6kg : add - 2. #3n9h2vkhe3 : add - 3. #2f9h2uhlk9 : builtins.merge + 1. #c7p2o500b5 : add + 2. #chv8uql7m1 : add + 3. #8eh9l1p8vo : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index b81f736d35..85ecdf60dc 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #7ms46v3pba > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #2gpohro3j9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #7ms46v3pba > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #2gpohro3j9 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #jqps95msh5 + ⊙ #pd0uqrl239 - Deletes: Nat.* Nat.+ - □ #fhun4m3q9g (start of history) + □ #6s4ppfd04c (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 1c98d31cadf346f6b4cfdfad90e1c9c478420bde Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 10 Sep 2021 16:13:56 -0400 Subject: [PATCH 076/148] Fix errors in calling convention of code cache instruction --- parser-typechecker/src/Unison/Runtime/Machine.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 6b50de912f..dad14b488f 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -217,7 +217,7 @@ exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do unknown <- cacheAdd news env bstk <- bump bstk pokeS bstk - (Sq.fromList $ Foreign . Wrap Rf.typeLinkRef . Ref <$> unknown) + (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, ustk, bstk, k) exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do clink <- peekOff bstk i @@ -1458,7 +1458,9 @@ decodeCacheArgument :: Sq.Seq Closure -> IO [(Reference, SuperGroup Symbol)] decodeCacheArgument s = for (toList s) $ \case DataB2 _ _ (Foreign x) (DataB2 _ _ (Foreign y) _) - -> pure (unwrapForeign x, unwrapForeign y) + -> case unwrapForeign x of + Ref r -> pure (r, unwrapForeign y) + _ -> die "decodeCacheArgument: Con reference" _ -> die "decodeCacheArgument: unrecognized value" addRefs From 132e23d989d386fdb3ead2c83f17d19a7288facb Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 10 Sep 2021 16:20:39 -0400 Subject: [PATCH 077/148] Unison.Hashing.V1.Convert.hash{Term,Type}Components --- .../src/Unison/Hashing/V1/Convert.hs | 147 ++++++++++++++++-- 1 file changed, 136 insertions(+), 11 deletions(-) diff --git a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs index c59bd9e2bb..8041c9c4c4 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -module Unison.Hashing.V1.Convert (hashDecls) where +module Unison.Hashing.V1.Convert (hashDecls, hashTermComponents, hashTypeComponents) where import Control.Lens (over, _3) import qualified Control.Lens as Lens @@ -13,9 +13,13 @@ import qualified Unison.ABT as ABT import qualified Unison.DataDeclaration as Memory.DD import Unison.Hash (Hash) import qualified Unison.Hashing.V1.DataDeclaration as Hashing.DD +import qualified Unison.Hashing.V1.Pattern as Hashing.Pattern import qualified Unison.Hashing.V1.Reference as Hashing.Reference +import qualified Unison.Hashing.V1.Referent as Hashing.Referent +import qualified Unison.Hashing.V1.Term as Hashing.Term import qualified Unison.Hashing.V1.Type as Hashing.Type import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Pattern as Memory.Pattern import qualified Unison.Reference as Memory.Reference import qualified Unison.Referent as Memory.Referent import qualified Unison.Term as Memory.Term @@ -39,15 +43,139 @@ convertResolutionResult = \case Names.TermResolutionFailure v a rs -> TermResolutionFailure v a rs Names.TypeResolutionFailure v a rs -> TypeResolutionFailure v a rs -hashTypeComponents - :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) +hashTypeComponents :: + Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) hashTypeComponents f memTypes = do hashingTypes <- traverse (m2hType f) memTypes let hashingResult = Hashing.Type.hashComponents hashingTypes pure $ fmap h2mTypeResult hashingResult + where + h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) + h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp) + +hashTermComponents :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Term.Term v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Term.Term v a)) +hashTermComponents f memTerms = do + hashingTerms <- traverse (m2hTerm f) memTerms + let hashingResult = Hashing.Term.hashComponents hashingTerms + pure $ fmap h2mTermResult hashingResult + where + h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a) + h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm) + + +m2hTerm :: Ord v => (Hash -> Maybe Hashing.Reference.Size) -> Memory.Term.Term v a -> Validate (Seq Hash) (Hashing.Term.Term v a) +m2hTerm f = ABT.transformM \case + Memory.Term.Int i -> pure $ Hashing.Term.Int i + Memory.Term.Nat n -> pure $ Hashing.Term.Nat n + Memory.Term.Float d -> pure $ Hashing.Term.Float d + Memory.Term.Boolean b -> pure $ Hashing.Term.Boolean b + Memory.Term.Text t -> pure $ Hashing.Term.Text t + Memory.Term.Char c -> pure $ Hashing.Term.Char c + Memory.Term.Blank b -> pure $ Hashing.Term.Blank b + Memory.Term.Ref r -> Hashing.Term.Ref <$> m2hReference f r + Memory.Term.Constructor r i -> Hashing.Term.Constructor <$> m2hReference f r <*> pure i + Memory.Term.Request r i -> Hashing.Term.Request <$> m2hReference f r <*> pure i + Memory.Term.Handle x y -> pure $ Hashing.Term.Handle x y + Memory.Term.App f x -> pure $ Hashing.Term.App f x + Memory.Term.Ann e t -> Hashing.Term.Ann e <$> m2hType f t + Memory.Term.List as -> pure $ Hashing.Term.List as + Memory.Term.If c t f -> pure $ Hashing.Term.If c t f + Memory.Term.And p q -> pure $ Hashing.Term.And p q + Memory.Term.Or p q -> pure $ Hashing.Term.Or p q + Memory.Term.Lam a -> pure $ Hashing.Term.Lam a + Memory.Term.LetRec isTop bs body -> pure $ Hashing.Term.LetRec isTop bs body + Memory.Term.Let isTop b body -> pure $ Hashing.Term.Let isTop b body + Memory.Term.Match scr cases -> Hashing.Term.Match scr <$> traverse (m2hMatchCase f) cases + Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent f r + Memory.Term.TypeLink r -> Hashing.Term.TypeLink <$> m2hReference f r + +m2hMatchCase :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Term.MatchCase a a1 -> Validate (Seq Hash) (Hashing.Term.MatchCase a a1) +m2hMatchCase f (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase <$> m2hPattern f pat <*> pure m_a1 <*> pure a1 + +m2hPattern :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Pattern.Pattern a -> Validate (Seq Hash) (Hashing.Pattern.Pattern a) +m2hPattern f = \case + Memory.Pattern.Unbound loc -> pure $ Hashing.Pattern.Unbound loc + Memory.Pattern.Var loc -> pure $ Hashing.Pattern.Var loc + Memory.Pattern.Boolean loc b -> pure $ Hashing.Pattern.Boolean loc b + Memory.Pattern.Int loc i -> pure $ Hashing.Pattern.Int loc i + Memory.Pattern.Nat loc n -> pure $ Hashing.Pattern.Nat loc n + Memory.Pattern.Float loc f -> pure $ Hashing.Pattern.Float loc f + Memory.Pattern.Text loc t -> pure $ Hashing.Pattern.Text loc t + Memory.Pattern.Char loc c -> pure $ Hashing.Pattern.Char loc c + Memory.Pattern.Constructor loc r i ps -> Hashing.Pattern.Constructor loc <$> m2hReference f r <*> pure i <*> traverse (m2hPattern f) ps + Memory.Pattern.As loc p -> Hashing.Pattern.As loc <$> m2hPattern f p + Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc <$> m2hPattern f p + Memory.Pattern.EffectBind loc r i ps k -> Hashing.Pattern.EffectBind loc <$> m2hReference f r <*> pure i <*> traverse (m2hPattern f) ps <*> m2hPattern f k + Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc <$> traverse (m2hPattern f) ps + Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc <$> m2hPattern f l <*> pure (m2hSequenceOp op) <*> m2hPattern f r + +m2hSequenceOp :: Memory.Pattern.SeqOp -> Hashing.Pattern.SeqOp +m2hSequenceOp = \case + Memory.Pattern.Cons -> Hashing.Pattern.Cons + Memory.Pattern.Snoc -> Hashing.Pattern.Snoc + Memory.Pattern.Concat -> Hashing.Pattern.Concat --- hashTermComponents :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a) --- hashTermComponents f memTerms = undefined +m2hReferent :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Referent.Referent -> Validate (Seq Hash) Hashing.Referent.Referent +m2hReferent f = \case + Memory.Referent.Ref ref -> Hashing.Referent.Ref <$> m2hReference f ref + Memory.Referent.Con ref n ct -> Hashing.Referent.Con <$> m2hReference f ref <*> pure n <*> pure ct + +h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a +h2mTerm = ABT.transform \case + Hashing.Term.Int i -> Memory.Term.Int i + Hashing.Term.Nat n -> Memory.Term.Nat n + Hashing.Term.Float d -> Memory.Term.Float d + Hashing.Term.Boolean b -> Memory.Term.Boolean b + Hashing.Term.Text t -> Memory.Term.Text t + Hashing.Term.Char c -> Memory.Term.Char c + Hashing.Term.Blank b -> Memory.Term.Blank b + Hashing.Term.Ref r -> Memory.Term.Ref (h2mReference r) + Hashing.Term.Constructor r i -> Memory.Term.Constructor (h2mReference r) i + Hashing.Term.Request r i -> Memory.Term.Request (h2mReference r) i + Hashing.Term.Handle x y -> Memory.Term.Handle x y + Hashing.Term.App f x -> Memory.Term.App f x + Hashing.Term.Ann e t -> Memory.Term.Ann e (h2mType t) + Hashing.Term.List as -> Memory.Term.List as + Hashing.Term.If c t f -> Memory.Term.If c t f + Hashing.Term.And p q -> Memory.Term.And p q + Hashing.Term.Or p q -> Memory.Term.Or p q + Hashing.Term.Lam a -> Memory.Term.Lam a + Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body + Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body + Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases) + Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent r) + Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r) + +h2mMatchCase :: Hashing.Term.MatchCase a b -> Memory.Term.MatchCase a b +h2mMatchCase (Hashing.Term.MatchCase pat m_b b) = Memory.Term.MatchCase (h2mPattern pat) m_b b + +h2mPattern :: Hashing.Pattern.Pattern a -> Memory.Pattern.Pattern a +h2mPattern = \case + Hashing.Pattern.Unbound loc -> Memory.Pattern.Unbound loc + Hashing.Pattern.Var loc -> Memory.Pattern.Var loc + Hashing.Pattern.Boolean loc b -> Memory.Pattern.Boolean loc b + Hashing.Pattern.Int loc i -> Memory.Pattern.Int loc i + Hashing.Pattern.Nat loc n -> Memory.Pattern.Nat loc n + Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f + Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t + Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c + Hashing.Pattern.Constructor loc r i ps -> Memory.Pattern.Constructor loc (h2mReference r) i (h2mPattern <$> ps) + Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p) + Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p) + Hashing.Pattern.EffectBind loc r i ps k -> Memory.Pattern.EffectBind loc (h2mReference r) i (h2mPattern <$> ps) (h2mPattern k) + Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps) + Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r) + +h2mSequenceOp :: Hashing.Pattern.SeqOp -> Memory.Pattern.SeqOp +h2mSequenceOp = \case + Hashing.Pattern.Cons -> Memory.Pattern.Cons + Hashing.Pattern.Snoc -> Memory.Pattern.Snoc + Hashing.Pattern.Concat -> Memory.Pattern.Concat + +h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent +h2mReferent = \case + Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref) + Hashing.Referent.Con ref n ct -> Memory.Referent.Con (h2mReference ref) n ct hashDecls :: Var v => @@ -58,6 +186,9 @@ hashDecls f memDecls = do hashingDecls <- Validate.mapErrors (fmap CycleResolutionFailure) $ traverse (m2hDecl f) memDecls hashingResult <- convertResolutionResult $ Hashing.DD.hashDecls hashingDecls pure $ map h2mDeclResult hashingResult + where + h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) + h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) m2hDecl :: Ord v => @@ -112,12 +243,6 @@ m2hModifier = \case Memory.DD.Structural -> Hashing.DD.Structural Memory.DD.Unique text -> Hashing.DD.Unique text -h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) -h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) - -h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) -h2mTypeResult (id, dd) = (h2mReferenceId id, h2mType dd) - h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) From b7fc6c6f5d45079201146e1187e582262418f04e Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Fri, 10 Sep 2021 13:49:15 -0700 Subject: [PATCH 078/148] add a Any.unsafeExtrace builtin --- parser-typechecker/src/Unison/Builtin.hs | 3 +- .../src/Unison/Runtime/Builtin.hs | 2 + .../src/Unison/Runtime/Machine.hs | 3 +- unison-src/transcripts/alias-many.output.md | 777 +++++++++--------- unison-src/transcripts/any-extract.md | 25 + unison-src/transcripts/any-extract.output.md | 39 + .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 11 files changed, 483 insertions(+), 414 deletions(-) create mode 100644 unison-src/transcripts/any-extract.md create mode 100644 unison-src/transcripts/any-extract.output.md diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index e10a320803..ef6217a6e4 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -255,7 +255,8 @@ typeOf a f r = maybe a f (Map.lookup r termRefTypes) builtinsSrc :: Var v => [BuiltinDSL v] builtinsSrc = - [ B "Int.+" $ int --> int --> int + [ B "Any.unsafeExtract" $ forall1 "a" (\a -> anyt --> a) + , B "Int.+" $ int --> int --> int , B "Int.-" $ int --> int --> int , B "Int.*" $ int --> int --> int , B "Int./" $ int --> int --> int diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 458c145505..d534ae06ef 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1800,6 +1800,8 @@ declareForeigns = do declareForeign "Any.Any" boxDirect . mkForeign $ \(a :: Closure) -> pure $ Closure.DataB1 Ty.anyRef 0 a + declareForeign "Any.unsafeExtract" boxDirect . mkForeign $ \(Closure.DataB1 _ _ a) -> pure $ a + -- Hashing functions let declareHashAlgorithm :: forall v alg . Var v => Hash.HashAlgorithm alg => Text -> alg -> FDecl v () declareHashAlgorithm txt alg = do diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 0c5764e54f..a1dd6e3341 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -1480,6 +1480,7 @@ cacheAdd0 ntys0 tml cc = atomically $ do let new = M.difference toAdd have sz = fromIntegral $ M.size new (rs,gs) = unzip $ M.toList new + int <- writeTVar (intermed cc) (have <> new) rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 ntm <- stateTVar (freshTm cc) $ \i -> (i, i+sz) rtm <- updateMap (M.fromList $ zip rs [ntm..]) (refTm cc) @@ -1488,7 +1489,7 @@ cacheAdd0 ntys0 tml cc = atomically $ do combinate n g = (n, emitCombs rns n g) nrs <- updateMap (mapFromList $ zip [ntm..] rs) (combRefs cc) ncs <- updateMap (mapFromList $ zipWith combinate [ntm..] gs) (combs cc) - pure $ rtm `seq` nrs `seq` ncs `seq` () + pure $ int `seq` rtm `seq` nrs `seq` ncs `seq` () where toAdd = M.fromList tml diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 5a574d173d..6e47d4bf40 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -20,442 +20,443 @@ Let's try it! 1. builtin type Any 2. Any.Any : a -> Any - 3. builtin type Boolean - 4. Boolean.not : Boolean -> Boolean - 5. bug : a -> b - 6. builtin type Bytes - 7. Bytes.++ : Bytes -> Bytes -> Bytes - 8. Bytes.at : Nat -> Bytes -> Optional Nat - 9. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) - 10. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) - 11. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) - 12. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) - 13. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) - 14. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) - 15. Bytes.drop : Nat -> Bytes -> Bytes - 16. Bytes.empty : Bytes - 17. Bytes.encodeNat16be : Nat -> Bytes - 18. Bytes.encodeNat16le : Nat -> Bytes - 19. Bytes.encodeNat32be : Nat -> Bytes - 20. Bytes.encodeNat32le : Nat -> Bytes - 21. Bytes.encodeNat64be : Nat -> Bytes - 22. Bytes.encodeNat64le : Nat -> Bytes - 23. Bytes.flatten : Bytes -> Bytes - 24. Bytes.fromBase16 : Bytes -> Either Text Bytes - 25. Bytes.fromBase32 : Bytes -> Either Text Bytes - 26. Bytes.fromBase64 : Bytes -> Either Text Bytes - 27. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 28. Bytes.fromList : [Nat] -> Bytes - 29. Bytes.size : Bytes -> Nat - 30. Bytes.take : Nat -> Bytes -> Bytes - 31. Bytes.toBase16 : Bytes -> Bytes - 32. Bytes.toBase32 : Bytes -> Bytes - 33. Bytes.toBase64 : Bytes -> Bytes - 34. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 35. Bytes.toList : Bytes -> [Nat] - 36. builtin type Char - 37. Char.fromNat : Nat -> Char - 38. Char.toNat : Char -> Nat - 39. Char.toText : Char -> Text - 40. builtin type Code - 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 42. Code.dependencies : Code -> [Term] - 43. Code.deserialize : Bytes -> Either Text Code - 44. Code.isMissing : Term ->{IO} Boolean - 45. Code.lookup : Term ->{IO} Optional Code - 46. Code.serialize : Code -> Bytes - 47. crypto.hash : HashAlgorithm -> a -> Bytes - 48. builtin type crypto.HashAlgorithm - 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 58. crypto.hmacBytes : HashAlgorithm + 3. Any.unsafeExtract : Any -> a + 4. builtin type Boolean + 5. Boolean.not : Boolean -> Boolean + 6. bug : a -> b + 7. builtin type Bytes + 8. Bytes.++ : Bytes -> Bytes -> Bytes + 9. Bytes.at : Nat -> Bytes -> Optional Nat + 10. Bytes.decodeNat16be : Bytes -> Optional (Nat, Bytes) + 11. Bytes.decodeNat16le : Bytes -> Optional (Nat, Bytes) + 12. Bytes.decodeNat32be : Bytes -> Optional (Nat, Bytes) + 13. Bytes.decodeNat32le : Bytes -> Optional (Nat, Bytes) + 14. Bytes.decodeNat64be : Bytes -> Optional (Nat, Bytes) + 15. Bytes.decodeNat64le : Bytes -> Optional (Nat, Bytes) + 16. Bytes.drop : Nat -> Bytes -> Bytes + 17. Bytes.empty : Bytes + 18. Bytes.encodeNat16be : Nat -> Bytes + 19. Bytes.encodeNat16le : Nat -> Bytes + 20. Bytes.encodeNat32be : Nat -> Bytes + 21. Bytes.encodeNat32le : Nat -> Bytes + 22. Bytes.encodeNat64be : Nat -> Bytes + 23. Bytes.encodeNat64le : Nat -> Bytes + 24. Bytes.flatten : Bytes -> Bytes + 25. Bytes.fromBase16 : Bytes -> Either Text Bytes + 26. Bytes.fromBase32 : Bytes -> Either Text Bytes + 27. Bytes.fromBase64 : Bytes -> Either Text Bytes + 28. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes + 29. Bytes.fromList : [Nat] -> Bytes + 30. Bytes.size : Bytes -> Nat + 31. Bytes.take : Nat -> Bytes -> Bytes + 32. Bytes.toBase16 : Bytes -> Bytes + 33. Bytes.toBase32 : Bytes -> Bytes + 34. Bytes.toBase64 : Bytes -> Bytes + 35. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 36. Bytes.toList : Bytes -> [Nat] + 37. builtin type Char + 38. Char.fromNat : Nat -> Char + 39. Char.toNat : Char -> Nat + 40. Char.toText : Char -> Text + 41. builtin type Code + 42. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 43. Code.dependencies : Code -> [Term] + 44. Code.deserialize : Bytes -> Either Text Code + 45. Code.isMissing : Term ->{IO} Boolean + 46. Code.lookup : Term ->{IO} Optional Code + 47. Code.serialize : Code -> Bytes + 48. crypto.hash : HashAlgorithm -> a -> Bytes + 49. builtin type crypto.HashAlgorithm + 50. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 51. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 52. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 53. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 54. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 55. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 56. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 57. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 58. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 59. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 59. Debug.watch : Text -> a -> a - 60. unique type Doc - 61. Doc.Blob : Text -> Doc - 62. Doc.Evaluate : Term -> Doc - 63. Doc.Join : [Doc] -> Doc - 64. Doc.Link : Link -> Doc - 65. Doc.Signature : Term -> Doc - 66. Doc.Source : Link -> Doc - 67. structural type Either a b - 68. Either.Left : a -> Either a b - 69. Either.Right : b -> Either a b - 70. structural ability Exception - 71. Exception.raise : Failure ->{Exception} x - 72. builtin type Float - 73. Float.* : Float -> Float -> Float - 74. Float.+ : Float -> Float -> Float - 75. Float.- : Float -> Float -> Float - 76. Float./ : Float -> Float -> Float - 77. Float.abs : Float -> Float - 78. Float.acos : Float -> Float - 79. Float.acosh : Float -> Float - 80. Float.asin : Float -> Float - 81. Float.asinh : Float -> Float - 82. Float.atan : Float -> Float - 83. Float.atan2 : Float -> Float -> Float - 84. Float.atanh : Float -> Float - 85. Float.ceiling : Float -> Int - 86. Float.cos : Float -> Float - 87. Float.cosh : Float -> Float - 88. Float.eq : Float -> Float -> Boolean - 89. Float.exp : Float -> Float - 90. Float.floor : Float -> Int - 91. Float.fromRepresentation : Nat -> Float - 92. Float.fromText : Text -> Optional Float - 93. Float.gt : Float -> Float -> Boolean - 94. Float.gteq : Float -> Float -> Boolean - 95. Float.log : Float -> Float - 96. Float.logBase : Float -> Float -> Float - 97. Float.lt : Float -> Float -> Boolean - 98. Float.lteq : Float -> Float -> Boolean - 99. Float.max : Float -> Float -> Float - 100. Float.min : Float -> Float -> Float - 101. Float.pow : Float -> Float -> Float - 102. Float.round : Float -> Int - 103. Float.sin : Float -> Float - 104. Float.sinh : Float -> Float - 105. Float.sqrt : Float -> Float - 106. Float.tan : Float -> Float - 107. Float.tanh : Float -> Float - 108. Float.toRepresentation : Float -> Nat - 109. Float.toText : Float -> Text - 110. Float.truncate : Float -> Int - 111. builtin type Int - 112. Int.* : Int -> Int -> Int - 113. Int.+ : Int -> Int -> Int - 114. Int.- : Int -> Int -> Int - 115. Int./ : Int -> Int -> Int - 116. Int.and : Int -> Int -> Int - 117. Int.complement : Int -> Int - 118. Int.eq : Int -> Int -> Boolean - 119. Int.fromRepresentation : Nat -> Int - 120. Int.fromText : Text -> Optional Int - 121. Int.gt : Int -> Int -> Boolean - 122. Int.gteq : Int -> Int -> Boolean - 123. Int.increment : Int -> Int - 124. Int.isEven : Int -> Boolean - 125. Int.isOdd : Int -> Boolean - 126. Int.leadingZeros : Int -> Nat - 127. Int.lt : Int -> Int -> Boolean - 128. Int.lteq : Int -> Int -> Boolean - 129. Int.mod : Int -> Int -> Int - 130. Int.negate : Int -> Int - 131. Int.or : Int -> Int -> Int - 132. Int.popCount : Int -> Nat - 133. Int.pow : Int -> Nat -> Int - 134. Int.shiftLeft : Int -> Nat -> Int - 135. Int.shiftRight : Int -> Nat -> Int - 136. Int.signum : Int -> Int - 137. Int.toFloat : Int -> Float - 138. Int.toRepresentation : Int -> Nat - 139. Int.toText : Int -> Text - 140. Int.trailingZeros : Int -> Nat - 141. Int.truncate0 : Int -> Nat - 142. Int.xor : Int -> Int -> Int - 143. unique type io2.BufferMode - 144. io2.BufferMode.BlockBuffering : BufferMode - 145. io2.BufferMode.LineBuffering : BufferMode - 146. io2.BufferMode.NoBuffering : BufferMode - 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 148. unique type io2.Failure - 149. io2.Failure.Failure : Type -> Text -> Any -> Failure - 150. unique type io2.FileMode - 151. io2.FileMode.Append : FileMode - 152. io2.FileMode.Read : FileMode - 153. io2.FileMode.ReadWrite : FileMode - 154. io2.FileMode.Write : FileMode - 155. builtin type io2.Handle - 156. builtin type io2.IO - 157. io2.IO.clientSocket.impl : Text + 60. Debug.watch : Text -> a -> a + 61. unique type Doc + 62. Doc.Blob : Text -> Doc + 63. Doc.Evaluate : Term -> Doc + 64. Doc.Join : [Doc] -> Doc + 65. Doc.Link : Link -> Doc + 66. Doc.Signature : Term -> Doc + 67. Doc.Source : Link -> Doc + 68. structural type Either a b + 69. Either.Left : a -> Either a b + 70. Either.Right : b -> Either a b + 71. structural ability Exception + 72. Exception.raise : Failure ->{Exception} x + 73. builtin type Float + 74. Float.* : Float -> Float -> Float + 75. Float.+ : Float -> Float -> Float + 76. Float.- : Float -> Float -> Float + 77. Float./ : Float -> Float -> Float + 78. Float.abs : Float -> Float + 79. Float.acos : Float -> Float + 80. Float.acosh : Float -> Float + 81. Float.asin : Float -> Float + 82. Float.asinh : Float -> Float + 83. Float.atan : Float -> Float + 84. Float.atan2 : Float -> Float -> Float + 85. Float.atanh : Float -> Float + 86. Float.ceiling : Float -> Int + 87. Float.cos : Float -> Float + 88. Float.cosh : Float -> Float + 89. Float.eq : Float -> Float -> Boolean + 90. Float.exp : Float -> Float + 91. Float.floor : Float -> Int + 92. Float.fromRepresentation : Nat -> Float + 93. Float.fromText : Text -> Optional Float + 94. Float.gt : Float -> Float -> Boolean + 95. Float.gteq : Float -> Float -> Boolean + 96. Float.log : Float -> Float + 97. Float.logBase : Float -> Float -> Float + 98. Float.lt : Float -> Float -> Boolean + 99. Float.lteq : Float -> Float -> Boolean + 100. Float.max : Float -> Float -> Float + 101. Float.min : Float -> Float -> Float + 102. Float.pow : Float -> Float -> Float + 103. Float.round : Float -> Int + 104. Float.sin : Float -> Float + 105. Float.sinh : Float -> Float + 106. Float.sqrt : Float -> Float + 107. Float.tan : Float -> Float + 108. Float.tanh : Float -> Float + 109. Float.toRepresentation : Float -> Nat + 110. Float.toText : Float -> Text + 111. Float.truncate : Float -> Int + 112. builtin type Int + 113. Int.* : Int -> Int -> Int + 114. Int.+ : Int -> Int -> Int + 115. Int.- : Int -> Int -> Int + 116. Int./ : Int -> Int -> Int + 117. Int.and : Int -> Int -> Int + 118. Int.complement : Int -> Int + 119. Int.eq : Int -> Int -> Boolean + 120. Int.fromRepresentation : Nat -> Int + 121. Int.fromText : Text -> Optional Int + 122. Int.gt : Int -> Int -> Boolean + 123. Int.gteq : Int -> Int -> Boolean + 124. Int.increment : Int -> Int + 125. Int.isEven : Int -> Boolean + 126. Int.isOdd : Int -> Boolean + 127. Int.leadingZeros : Int -> Nat + 128. Int.lt : Int -> Int -> Boolean + 129. Int.lteq : Int -> Int -> Boolean + 130. Int.mod : Int -> Int -> Int + 131. Int.negate : Int -> Int + 132. Int.or : Int -> Int -> Int + 133. Int.popCount : Int -> Nat + 134. Int.pow : Int -> Nat -> Int + 135. Int.shiftLeft : Int -> Nat -> Int + 136. Int.shiftRight : Int -> Nat -> Int + 137. Int.signum : Int -> Int + 138. Int.toFloat : Int -> Float + 139. Int.toRepresentation : Int -> Nat + 140. Int.toText : Int -> Text + 141. Int.trailingZeros : Int -> Nat + 142. Int.truncate0 : Int -> Nat + 143. Int.xor : Int -> Int -> Int + 144. unique type io2.BufferMode + 145. io2.BufferMode.BlockBuffering : BufferMode + 146. io2.BufferMode.LineBuffering : BufferMode + 147. io2.BufferMode.NoBuffering : BufferMode + 148. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 149. unique type io2.Failure + 150. io2.Failure.Failure : Type -> Text -> Any -> Failure + 151. unique type io2.FileMode + 152. io2.FileMode.Append : FileMode + 153. io2.FileMode.Read : FileMode + 154. io2.FileMode.ReadWrite : FileMode + 155. io2.FileMode.Write : FileMode + 156. builtin type io2.Handle + 157. builtin type io2.IO + 158. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 160. io2.IO.createDirectory.impl : Text + 159. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 160. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 161. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 161. io2.IO.createTempDirectory.impl : Text + 162. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 163. io2.IO.directoryContents.impl : Text + 163. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 164. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 164. io2.IO.fileExists.impl : Text + 165. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 166. io2.IO.getBuffering.impl : Handle + 166. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 167. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 167. io2.IO.getBytes.impl : Handle + 168. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 168. io2.IO.getCurrentDirectory.impl : '{IO} Either + 169. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 171. io2.IO.getFileTimestamp.impl : Text + 170. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 171. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 172. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 174. io2.IO.handlePosition.impl : Handle + 173. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 174. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 175. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 175. io2.IO.isDirectory.impl : Text + 176. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 176. io2.IO.isFileEOF.impl : Handle + 177. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 177. io2.IO.isFileOpen.impl : Handle + 178. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isSeekable.impl : Handle + 179. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 181. io2.IO.openFile.impl : Text + 180. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 181. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 182. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 182. io2.IO.putBytes.impl : Handle + 183. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 183. io2.IO.ref : a ->{IO} Ref {IO} a - 184. io2.IO.removeDirectory.impl : Text + 184. io2.IO.ref : a ->{IO} Ref {IO} a + 185. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 186. io2.IO.renameDirectory.impl : Text + 186. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 187. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 187. io2.IO.renameFile.impl : Text + 188. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 188. io2.IO.seekHandle.impl : Handle + 189. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 189. io2.IO.serverSocket.impl : Optional Text + 190. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 190. io2.IO.setBuffering.impl : Handle + 191. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 191. io2.IO.setCurrentDirectory.impl : Text + 192. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 192. io2.IO.socketAccept.impl : Socket + 193. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 193. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 194. io2.IO.socketReceive.impl : Socket + 194. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 195. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 195. io2.IO.socketSend.impl : Socket + 196. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 196. io2.IO.stdHandle : StdHandle -> Handle - 197. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 198. unique type io2.IOError - 199. io2.IOError.AlreadyExists : IOError - 200. io2.IOError.EOF : IOError - 201. io2.IOError.IllegalOperation : IOError - 202. io2.IOError.NoSuchThing : IOError - 203. io2.IOError.PermissionDenied : IOError - 204. io2.IOError.ResourceBusy : IOError - 205. io2.IOError.ResourceExhausted : IOError - 206. io2.IOError.UserError : IOError - 207. unique type io2.IOFailure - 208. builtin type io2.MVar - 209. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 210. io2.MVar.new : a ->{IO} MVar a - 211. io2.MVar.newEmpty : '{IO} MVar a - 212. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 213. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 214. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 215. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 216. io2.MVar.tryPut.impl : MVar a + 197. io2.IO.stdHandle : StdHandle -> Handle + 198. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 199. unique type io2.IOError + 200. io2.IOError.AlreadyExists : IOError + 201. io2.IOError.EOF : IOError + 202. io2.IOError.IllegalOperation : IOError + 203. io2.IOError.NoSuchThing : IOError + 204. io2.IOError.PermissionDenied : IOError + 205. io2.IOError.ResourceBusy : IOError + 206. io2.IOError.ResourceExhausted : IOError + 207. io2.IOError.UserError : IOError + 208. unique type io2.IOFailure + 209. builtin type io2.MVar + 210. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 211. io2.MVar.new : a ->{IO} MVar a + 212. io2.MVar.newEmpty : '{IO} MVar a + 213. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 214. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 215. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 216. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 217. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 217. io2.MVar.tryRead.impl : MVar a + 218. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 218. io2.MVar.tryTake : MVar a ->{IO} Optional a - 219. unique type io2.SeekMode - 220. io2.SeekMode.AbsoluteSeek : SeekMode - 221. io2.SeekMode.RelativeSeek : SeekMode - 222. io2.SeekMode.SeekFromEnd : SeekMode - 223. builtin type io2.Socket - 224. unique type io2.StdHandle - 225. io2.StdHandle.StdErr : StdHandle - 226. io2.StdHandle.StdIn : StdHandle - 227. io2.StdHandle.StdOut : StdHandle - 228. builtin type io2.STM - 229. io2.STM.atomically : '{STM} a ->{IO} a - 230. io2.STM.retry : '{STM} a - 231. builtin type io2.ThreadId - 232. builtin type io2.Tls - 233. builtin type io2.Tls.Cipher - 234. builtin type io2.Tls.ClientConfig - 235. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 219. io2.MVar.tryTake : MVar a ->{IO} Optional a + 220. unique type io2.SeekMode + 221. io2.SeekMode.AbsoluteSeek : SeekMode + 222. io2.SeekMode.RelativeSeek : SeekMode + 223. io2.SeekMode.SeekFromEnd : SeekMode + 224. builtin type io2.Socket + 225. unique type io2.StdHandle + 226. io2.StdHandle.StdErr : StdHandle + 227. io2.StdHandle.StdIn : StdHandle + 228. io2.StdHandle.StdOut : StdHandle + 229. builtin type io2.STM + 230. io2.STM.atomically : '{STM} a ->{IO} a + 231. io2.STM.retry : '{STM} a + 232. builtin type io2.ThreadId + 233. builtin type io2.Tls + 234. builtin type io2.Tls.Cipher + 235. builtin type io2.Tls.ClientConfig + 236. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 236. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 237. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 237. io2.Tls.ClientConfig.default : Text + 238. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 238. io2.Tls.ClientConfig.versions.set : [Version] + 239. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 239. io2.Tls.decodeCert.impl : Bytes + 240. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 240. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 241. io2.Tls.encodeCert : SignedCert -> Bytes - 242. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 243. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 244. io2.Tls.newClient.impl : ClientConfig + 241. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 242. io2.Tls.encodeCert : SignedCert -> Bytes + 243. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 244. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 245. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 245. io2.Tls.newServer.impl : ServerConfig + 246. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 246. builtin type io2.Tls.PrivateKey - 247. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 248. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 249. builtin type io2.Tls.ServerConfig - 250. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 247. builtin type io2.Tls.PrivateKey + 248. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 249. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 250. builtin type io2.Tls.ServerConfig + 251. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 251. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 252. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 252. io2.Tls.ServerConfig.default : [SignedCert] + 253. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 253. io2.Tls.ServerConfig.versions.set : [Version] + 254. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 254. builtin type io2.Tls.SignedCert - 255. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 256. builtin type io2.Tls.Version - 257. unique type io2.TlsFailure - 258. builtin type io2.TVar - 259. io2.TVar.new : a ->{STM} TVar a - 260. io2.TVar.newIO : a ->{IO} TVar a - 261. io2.TVar.read : TVar a ->{STM} a - 262. io2.TVar.readIO : TVar a ->{IO} a - 263. io2.TVar.swap : TVar a -> a ->{STM} a - 264. io2.TVar.write : TVar a -> a ->{STM} () - 265. unique type IsPropagated - 266. IsPropagated.IsPropagated : IsPropagated - 267. unique type IsTest - 268. IsTest.IsTest : IsTest - 269. unique type Link - 270. builtin type Link.Term - 271. Link.Term : Term -> Link - 272. builtin type Link.Type - 273. Link.Type : Type -> Link - 274. builtin type List - 275. List.++ : [a] -> [a] -> [a] - 276. List.+: : a -> [a] -> [a] - 277. List.:+ : [a] -> a -> [a] - 278. List.at : Nat -> [a] -> Optional a - 279. List.cons : a -> [a] -> [a] - 280. List.drop : Nat -> [a] -> [a] - 281. List.empty : [a] - 282. List.size : [a] -> Nat - 283. List.snoc : [a] -> a -> [a] - 284. List.take : Nat -> [a] -> [a] - 285. metadata.isPropagated : IsPropagated - 286. metadata.isTest : IsTest - 287. builtin type Nat - 288. Nat.* : Nat -> Nat -> Nat - 289. Nat.+ : Nat -> Nat -> Nat - 290. Nat./ : Nat -> Nat -> Nat - 291. Nat.and : Nat -> Nat -> Nat - 292. Nat.complement : Nat -> Nat - 293. Nat.drop : Nat -> Nat -> Nat - 294. Nat.eq : Nat -> Nat -> Boolean - 295. Nat.fromText : Text -> Optional Nat - 296. Nat.gt : Nat -> Nat -> Boolean - 297. Nat.gteq : Nat -> Nat -> Boolean - 298. Nat.increment : Nat -> Nat - 299. Nat.isEven : Nat -> Boolean - 300. Nat.isOdd : Nat -> Boolean - 301. Nat.leadingZeros : Nat -> Nat - 302. Nat.lt : Nat -> Nat -> Boolean - 303. Nat.lteq : Nat -> Nat -> Boolean - 304. Nat.mod : Nat -> Nat -> Nat - 305. Nat.or : Nat -> Nat -> Nat - 306. Nat.popCount : Nat -> Nat - 307. Nat.pow : Nat -> Nat -> Nat - 308. Nat.shiftLeft : Nat -> Nat -> Nat - 309. Nat.shiftRight : Nat -> Nat -> Nat - 310. Nat.sub : Nat -> Nat -> Int - 311. Nat.toFloat : Nat -> Float - 312. Nat.toInt : Nat -> Int - 313. Nat.toText : Nat -> Text - 314. Nat.trailingZeros : Nat -> Nat - 315. Nat.xor : Nat -> Nat -> Nat - 316. structural type Optional a - 317. Optional.None : Optional a - 318. Optional.Some : a -> Optional a - 319. builtin type Ref - 320. Ref.read : Ref g a ->{g} a - 321. Ref.write : Ref g a -> a ->{g} () - 322. builtin type Request - 323. builtin type Scope - 324. Scope.ref : a ->{Scope s} Ref {Scope s} a - 325. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 326. structural type SeqView a b - 327. SeqView.VElem : a -> b -> SeqView a b - 328. SeqView.VEmpty : SeqView a b - 329. unique type Test.Result - 330. Test.Result.Fail : Text -> Result - 331. Test.Result.Ok : Text -> Result - 332. builtin type Text - 333. Text.!= : Text -> Text -> Boolean - 334. Text.++ : Text -> Text -> Text - 335. Text.drop : Nat -> Text -> Text - 336. Text.empty : Text - 337. Text.eq : Text -> Text -> Boolean - 338. Text.fromCharList : [Char] -> Text - 339. Text.fromUtf8.impl : Bytes -> Either Failure Text - 340. Text.gt : Text -> Text -> Boolean - 341. Text.gteq : Text -> Text -> Boolean - 342. Text.lt : Text -> Text -> Boolean - 343. Text.lteq : Text -> Text -> Boolean - 344. Text.repeat : Nat -> Text -> Text - 345. Text.size : Text -> Nat - 346. Text.take : Nat -> Text -> Text - 347. Text.toCharList : Text -> [Char] - 348. Text.toUtf8 : Text -> Bytes - 349. Text.uncons : Text -> Optional (Char, Text) - 350. Text.unsnoc : Text -> Optional (Text, Char) - 351. todo : a -> b - 352. structural type Tuple a b - 353. Tuple.Cons : a -> b -> Tuple a b - 354. structural type Unit - 355. Unit.Unit : () - 356. Universal.< : a -> a -> Boolean - 357. Universal.<= : a -> a -> Boolean - 358. Universal.== : a -> a -> Boolean - 359. Universal.> : a -> a -> Boolean - 360. Universal.>= : a -> a -> Boolean - 361. Universal.compare : a -> a -> Int - 362. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 363. builtin type Value - 364. Value.dependencies : Value -> [Term] - 365. Value.deserialize : Bytes -> Either Text Value - 366. Value.load : Value ->{IO} Either [Term] a - 367. Value.serialize : Value -> Bytes - 368. Value.value : a -> Value + 255. builtin type io2.Tls.SignedCert + 256. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 257. builtin type io2.Tls.Version + 258. unique type io2.TlsFailure + 259. builtin type io2.TVar + 260. io2.TVar.new : a ->{STM} TVar a + 261. io2.TVar.newIO : a ->{IO} TVar a + 262. io2.TVar.read : TVar a ->{STM} a + 263. io2.TVar.readIO : TVar a ->{IO} a + 264. io2.TVar.swap : TVar a -> a ->{STM} a + 265. io2.TVar.write : TVar a -> a ->{STM} () + 266. unique type IsPropagated + 267. IsPropagated.IsPropagated : IsPropagated + 268. unique type IsTest + 269. IsTest.IsTest : IsTest + 270. unique type Link + 271. builtin type Link.Term + 272. Link.Term : Term -> Link + 273. builtin type Link.Type + 274. Link.Type : Type -> Link + 275. builtin type List + 276. List.++ : [a] -> [a] -> [a] + 277. List.+: : a -> [a] -> [a] + 278. List.:+ : [a] -> a -> [a] + 279. List.at : Nat -> [a] -> Optional a + 280. List.cons : a -> [a] -> [a] + 281. List.drop : Nat -> [a] -> [a] + 282. List.empty : [a] + 283. List.size : [a] -> Nat + 284. List.snoc : [a] -> a -> [a] + 285. List.take : Nat -> [a] -> [a] + 286. metadata.isPropagated : IsPropagated + 287. metadata.isTest : IsTest + 288. builtin type Nat + 289. Nat.* : Nat -> Nat -> Nat + 290. Nat.+ : Nat -> Nat -> Nat + 291. Nat./ : Nat -> Nat -> Nat + 292. Nat.and : Nat -> Nat -> Nat + 293. Nat.complement : Nat -> Nat + 294. Nat.drop : Nat -> Nat -> Nat + 295. Nat.eq : Nat -> Nat -> Boolean + 296. Nat.fromText : Text -> Optional Nat + 297. Nat.gt : Nat -> Nat -> Boolean + 298. Nat.gteq : Nat -> Nat -> Boolean + 299. Nat.increment : Nat -> Nat + 300. Nat.isEven : Nat -> Boolean + 301. Nat.isOdd : Nat -> Boolean + 302. Nat.leadingZeros : Nat -> Nat + 303. Nat.lt : Nat -> Nat -> Boolean + 304. Nat.lteq : Nat -> Nat -> Boolean + 305. Nat.mod : Nat -> Nat -> Nat + 306. Nat.or : Nat -> Nat -> Nat + 307. Nat.popCount : Nat -> Nat + 308. Nat.pow : Nat -> Nat -> Nat + 309. Nat.shiftLeft : Nat -> Nat -> Nat + 310. Nat.shiftRight : Nat -> Nat -> Nat + 311. Nat.sub : Nat -> Nat -> Int + 312. Nat.toFloat : Nat -> Float + 313. Nat.toInt : Nat -> Int + 314. Nat.toText : Nat -> Text + 315. Nat.trailingZeros : Nat -> Nat + 316. Nat.xor : Nat -> Nat -> Nat + 317. structural type Optional a + 318. Optional.None : Optional a + 319. Optional.Some : a -> Optional a + 320. builtin type Ref + 321. Ref.read : Ref g a ->{g} a + 322. Ref.write : Ref g a -> a ->{g} () + 323. builtin type Request + 324. builtin type Scope + 325. Scope.ref : a ->{Scope s} Ref {Scope s} a + 326. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 327. structural type SeqView a b + 328. SeqView.VElem : a -> b -> SeqView a b + 329. SeqView.VEmpty : SeqView a b + 330. unique type Test.Result + 331. Test.Result.Fail : Text -> Result + 332. Test.Result.Ok : Text -> Result + 333. builtin type Text + 334. Text.!= : Text -> Text -> Boolean + 335. Text.++ : Text -> Text -> Text + 336. Text.drop : Nat -> Text -> Text + 337. Text.empty : Text + 338. Text.eq : Text -> Text -> Boolean + 339. Text.fromCharList : [Char] -> Text + 340. Text.fromUtf8.impl : Bytes -> Either Failure Text + 341. Text.gt : Text -> Text -> Boolean + 342. Text.gteq : Text -> Text -> Boolean + 343. Text.lt : Text -> Text -> Boolean + 344. Text.lteq : Text -> Text -> Boolean + 345. Text.repeat : Nat -> Text -> Text + 346. Text.size : Text -> Nat + 347. Text.take : Nat -> Text -> Text + 348. Text.toCharList : Text -> [Char] + 349. Text.toUtf8 : Text -> Bytes + 350. Text.uncons : Text -> Optional (Char, Text) + 351. Text.unsnoc : Text -> Optional (Text, Char) + 352. todo : a -> b + 353. structural type Tuple a b + 354. Tuple.Cons : a -> b -> Tuple a b + 355. structural type Unit + 356. Unit.Unit : () + 357. Universal.< : a -> a -> Boolean + 358. Universal.<= : a -> a -> Boolean + 359. Universal.== : a -> a -> Boolean + 360. Universal.> : a -> a -> Boolean + 361. Universal.>= : a -> a -> Boolean + 362. Universal.compare : a -> a -> Int + 363. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 364. builtin type Value + 365. Value.dependencies : Value -> [Term] + 366. Value.deserialize : Bytes -> Either Text Value + 367. Value.load : Value ->{IO} Either [Term] a + 368. Value.serialize : Value -> Bytes + 369. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -464,17 +465,17 @@ Let's try it! Added definitions: - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.gt : Float -> Float -> Boolean + 2. Float.gteq : Float -> Float -> Boolean + 3. Float.log : Float -> Float + 4. Float.logBase : Float -> Float -> Float + 5. Float.lt : Float -> Float -> Boolean + 6. Float.lteq : Float -> Float -> Boolean + 7. Float.max : Float -> Float -> Float + 8. Float.min : Float -> Float -> Float + 9. Float.pow : Float -> Float -> Float + 10. Float.round : Float -> Int + 11. Float.sin : Float -> Float Tip: You can use `undo` or `reflog` to undo this change. @@ -534,17 +535,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.gt : Float -> Float -> Boolean + 2. Float.gteq : Float -> Float -> Boolean + 3. Float.log : Float -> Float + 4. Float.logBase : Float -> Float -> Float + 5. Float.lt : Float -> Float -> Boolean + 6. Float.lteq : Float -> Float -> Boolean + 7. Float.max : Float -> Float -> Float + 8. Float.min : Float -> Float -> Float + 9. Float.pow : Float -> Float -> Float + 10. Float.round : Float -> Int + 11. Float.sin : Float -> Float 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/any-extract.md b/unison-src/transcripts/any-extract.md new file mode 100644 index 0000000000..6463f11472 --- /dev/null +++ b/unison-src/transcripts/any-extract.md @@ -0,0 +1,25 @@ +# Unit tests for Any.unsafeExtract + +```ucm:hide +.> builtins.merge +.> cd builtin +.> load unison-src/transcripts-using-base/base.u +.> add +``` + +Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. + +```unison + +test> Any.unsafeExtract.works = + use Nat != + checks [1 == Any.unsafeExtract (Any 1), + not (1 == Any.unsafeExtract (Any 2)), + (Some 1) == Any.unsafeExtract (Any (Some 1)) + ] +``` + +```ucm +.> add +``` + diff --git a/unison-src/transcripts/any-extract.output.md b/unison-src/transcripts/any-extract.output.md new file mode 100644 index 0000000000..1fe1252014 --- /dev/null +++ b/unison-src/transcripts/any-extract.output.md @@ -0,0 +1,39 @@ +# Unit tests for Any.unsafeExtract + +Any.unsafeExtract is a way to extract the value contained in an Any. This is unsafe because it allows the programmer to coerce a value into any type, which would cause undefined behaviour if used to coerce a value to the wrong type. + +```unison +test> Any.unsafeExtract.works = + use Nat != + checks [1 == Any.unsafeExtract (Any 1), + not (1 == Any.unsafeExtract (Any 2)), + (Some 1) == Any.unsafeExtract (Any (Some 1)) + ] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + Any.unsafeExtract.works : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 3 | checks [1 == Any.unsafeExtract (Any 1), + + ✅ Passed Passed + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + Any.unsafeExtract.works : [Result] + +``` diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index c7410c7aa4..e96c998237 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -10,7 +10,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace .tmp> ls builtin 1. Any (builtin type) - 2. Any/ (1 definition) + 2. Any/ (2 definitions) 3. Boolean (builtin type) 4. Boolean/ (1 definition) 5. Bytes (builtin type) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index d427631348..f02fea7be8 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (368 definitions) + 1. builtin/ (369 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (536 definitions) + 1. builtin/ (537 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 0800365338..007aa20670 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #nl3sdb3eid + ⊙ #se9g0dsb5p - Deletes: feature1.y - ⊙ #nt4hpgmam9 + ⊙ #3ojeqsvma8 + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #hjtrj2kgl4 + ⊙ #74ar34it8e + Adds / updates: feature1.y - ⊙ #04vktkvglu + ⊙ #iou38omiep > Moves: Original name New name x master.x - ⊙ #0g638hmb59 + ⊙ #aabda4c39v + Adds / updates: x - □ #2f9h2uhlk9 (start of history) + □ #lhaj1c0t52 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index c4afd9df17..291e9e8b27 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #3n9h2vkhe3 .old` to make an old namespace + `fork #v3uv37ucsq .old` to make an old namespace accessible again, - `reset-root #3n9h2vkhe3` to reset the root namespace and + `reset-root #v3uv37ucsq` to reset the root namespace and its history to that of the specified namespace. - 1. #vfl0sjr6kg : add - 2. #3n9h2vkhe3 : add - 3. #2f9h2uhlk9 : builtins.merge + 1. #383mhnhi2g : add + 2. #v3uv37ucsq : add + 3. #lhaj1c0t52 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index b81f736d35..dc54e2c3fe 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #fhun4m3q9g (start of history) + □ #6j0l82egns (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #efhbojckj1 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #mfptev2048 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6j0l82egns (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #565pe56252 + ⊙ #efhbojckj1 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #oavs87p39a + ⊙ #mfptev2048 > Moves: Original name New name Nat.+ Nat.frobnicate - □ #fhun4m3q9g (start of history) + □ #6j0l82egns (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #fhun4m3q9g (start of history) + □ #6j0l82egns (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #jqps95msh5 + ⊙ #au5q89sjgq - Deletes: Nat.* Nat.+ - □ #fhun4m3q9g (start of history) + □ #6j0l82egns (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 3da39fd16d0e4a1555c9a4c736cea10e3a9ce87b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 10 Sep 2021 21:15:24 -0400 Subject: [PATCH 079/148] Change tabulation of binary operators --- parser-typechecker/src/Unison/TermPrinter.hs | 5 +---- unison-src/transcripts-round-trip/main.md | 2 +- unison-src/transcripts-round-trip/main.output.md | 12 ++++++------ 3 files changed, 8 insertions(+), 11 deletions(-) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index e79a45c65b..644214debe 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -413,10 +413,7 @@ pretty0 binaryApps xs last = unbroken `PP.orElse` broken where unbroken = PP.spaced (ps ++ [last]) - broken = case take 2 ps of - [x, y] -> PP.hang (x <> " " <> y) . PP.column2 . psCols $ (drop 2 ps ++ [last]) - [] -> last - _ -> undefined + broken = PP.hang (head ps) . PP.column2 . psCols $ (tail ps ++ [last]) psCols ps = case take 2 ps of [x, y] -> (x, y) : psCols (drop 2 ps) [x] -> [(x, "")] diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index f8224cb578..cf18aaec7c 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -138,7 +138,7 @@ Regression test for https://github.com/unisonweb/unison/issues/1035 ```unison:hide foo : Text foo = - "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddd" + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddddddddd" ``` ```ucm diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 58be640276..c933dddec8 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -398,7 +398,7 @@ Regression test for https://github.com/unisonweb/unison/issues/1035 ```unison foo : Text foo = - "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddd" + "aaaaaaaaaaaaaaaaaaaaaa" ++ "bbbbbbbbbbbbbbbbbbbbbb" ++ "cccccccccccccccccccccc" ++ "dddddddddddddddddddddd" ``` ```ucm @@ -418,10 +418,10 @@ foo = foo : Text foo = use Text ++ - "aaaaaaaaaaaaaaaaaaaaaa" ++ - "bbbbbbbbbbbbbbbbbbbbbb" ++ - "cccccccccccccccccccccc" ++ - "dddddddddddddddd" + "aaaaaaaaaaaaaaaaaaaaaa" + ++ "bbbbbbbbbbbbbbbbbbbbbb" + ++ "cccccccccccccccccccccc" + ++ "dddddddddddddddddddddd" You can edit them there, then do `update` to replace the definitions currently in this namespace. @@ -439,7 +439,7 @@ foo = its history to that of the specified namespace. - 1. #2hheevu1j3 : add + 1. #o6r7803627 : add 2. #pqvd5behc2 : reset-root #pqvd5behc2 3. #j32i1remee : add 4. #pqvd5behc2 : reset-root #pqvd5behc2 From 0273083cb70d8e22f4dd101a946bac11fcc13e91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Sat, 11 Sep 2021 05:08:16 -0400 Subject: [PATCH 080/148] Update transcript output --- unison-src/transcripts/bug-strange-closure.output.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md index e41357a504..1dfe955f0a 100644 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ b/unison-src/transcripts/bug-strange-closure.output.md @@ -2077,9 +2077,9 @@ rendered = Pretty.get (docFormatConsole doc.guide) (Term.Term (Any '(f x -> - f x Nat.+ - sqr - 1 ))))), + f x + Nat.+ sqr + 1))))), !Lit (Right (Plain "-")), From 4a60c89742a098bb49f7bca51173d879d8080b06 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 14 Sep 2021 12:09:47 -0700 Subject: [PATCH 081/148] removes init command, replaces with --codebase-create flag --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Init.hs | 68 +++++++++------ .../src/Unison/CommandLine/Main.hs | 1 - .../tests/Unison/Test/CodebaseInit.hs | 25 +++++- .../unison-parser-typechecker.cabal | 1 + parser-typechecker/unison/ArgParse.hs | 39 ++++++--- parser-typechecker/unison/Main.hs | 83 ++++++++++++------- 7 files changed, 149 insertions(+), 69 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 97a0acc882..d065317973 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -144,6 +144,7 @@ executables: - unison-parser-typechecker - unison-codebase-sync - uri-encode + - unliftio when: - condition: '!os(windows)' dependencies: unix diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 456e59aea3..3e72902a3b 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -5,14 +5,14 @@ module Unison.Codebase.Init ( Init (..), DebugName, InitError (..), - CodebaseDir (..), + CodebaseInitOptions (..), InitResult (..), + SpecifiedCodebase (..), Pretty, createCodebase, initCodebaseAndExit, openOrCreateCodebase, openNewUcmCodebaseOrExit, - homeOrSpecifiedDir ) where @@ -25,21 +25,23 @@ import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P -import UnliftIO.Directory (canonicalizePath, getHomeDirectory) +import UnliftIO.Directory (canonicalizePath) import Unison.Codebase.Init.CreateCodebaseError --- CodebaseDir is used to help pass around a Home directory that isn't the +-- CodebaseInitOptions is used to help pass around a Home directory that isn't the -- actual home directory of the user. Useful in tests. -data CodebaseDir = Home CodebasePath | Specified CodebasePath +data CodebaseInitOptions + = Home CodebasePath + | Specified SpecifiedCodebase -homeOrSpecifiedDir :: Maybe CodebasePath -> IO CodebaseDir -homeOrSpecifiedDir specifiedDir = do - homeDir <- getHomeDirectory - pure $ maybe (Home homeDir) Specified specifiedDir +data SpecifiedCodebase + = CreateWhenMissing CodebasePath + | DontCreateWhenMissing CodebasePath -codebaseDirToCodebasePath :: CodebaseDir -> CodebasePath -codebaseDirToCodebasePath (Home dir) = dir -codebaseDirToCodebasePath (Specified dir) = dir +initOptionsToDir :: CodebaseInitOptions -> CodebasePath +initOptionsToDir (Home dir ) = dir +initOptionsToDir (Specified (CreateWhenMissing dir)) = dir +initOptionsToDir (Specified (DontCreateWhenMissing dir)) = dir type DebugName = String @@ -65,28 +67,42 @@ data InitResult m v a | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) | Error CodebasePath InitError -openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseDir -> m (InitResult m v a) -openOrCreateCodebase cbInit debugName codebaseDir = do - let resolvedPath = (codebaseDirToCodebasePath codebaseDir) +createCodebaseWithResult :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (InitResult m v a) +createCodebaseWithResult cbInit debugName dir = + createCodebase cbInit debugName dir >>= \case + Left errorMessage -> do + pure (Error dir (CouldntCreateCodebase errorMessage)) + Right cb -> do + pure (CreatedCodebase dir cb) + +whenNoV1Codebase :: MonadIO m => CodebasePath -> m (InitResult m v a) -> m (InitResult m v a ) +whenNoV1Codebase dir initResult = + ifM (FCC.codebaseExists dir) + (pure (Error dir FoundV1Codebase)) + initResult + +openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseInitOptions -> m (InitResult m v a) +openOrCreateCodebase cbInit debugName initOptions = do + let resolvedPath = initOptionsToDir initOptions openCodebase cbInit debugName resolvedPath >>= \case Right cb -> pure (OpenedCodebase resolvedPath cb) Left _ -> - case codebaseDir of + case initOptions of Home homeDir -> do ifM (FCC.codebaseExists homeDir) (do pure (Error homeDir FoundV1Codebase)) (do -- Create V2 codebase if neither a V1 or V2 exists - createCodebase cbInit debugName homeDir >>= \case - Left errorMessage -> do - pure (Error homeDir (CouldntCreateCodebase errorMessage)) - Right cb -> do - pure (CreatedCodebase homeDir cb) + createCodebaseWithResult cbInit debugName homeDir ) - Specified specifiedDir -> do - ifM (FCC.codebaseExists specifiedDir) - (pure (Error specifiedDir FoundV1Codebase)) - (pure (Error specifiedDir NoCodebaseFoundAtSpecifiedDir)) + + Specified specificed -> + whenNoV1Codebase (initOptionsToDir initOptions) $ do + case specificed of + DontCreateWhenMissing dir -> + pure (Error dir NoCodebaseFoundAtSpecifiedDir) + CreateWhenMissing dir -> + createCodebaseWithResult cbInit debugName dir createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)) createCodebase cbInit debugName path = do @@ -123,6 +139,6 @@ openNewUcmCodebaseOrExit cbInit debugName path = do pure x -- | try to init a codebase where none exists and then exit regardless (i.e. `ucm -codebase dir init`) -initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () +initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () -- RLM : or could change here initCodebaseAndExit i debugName mdir = void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index 23c1986beb..d08441b646 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -46,7 +46,6 @@ import Text.Regex.TDFA import Control.Lens (view) import Control.Error (rightMay) - -- Expand a numeric argument like `1` or a range like `3-9` expandNumber :: [String] -> String -> [String] expandNumber numberedArgs s = diff --git a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs index caf03130f6..06be3ffdac 100644 --- a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs +++ b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs @@ -7,6 +7,10 @@ module Unison.Test.CodebaseInit where import EasyTest import qualified Unison.Codebase.Init as CI import Unison.Codebase.Init + ( CodebaseInitOptions(..) + , Init(..) + , SpecifiedCodebase(..) + ) import qualified System.IO.Temp as Temp -- keep it off for CI, since the random temp dirs it generates show up in the @@ -37,18 +41,35 @@ test = scope "Codebase.Init" $ tests [ scope "a v2 codebase should be opened" do tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") cbInit <- io initMockWithCodebase - res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified tmp)) + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp))) case res of CI.OpenedCodebase _ _ -> expect True _ -> expect False , scope "a v2 codebase should be *not* created when one does not exist at the Specified dir" do tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") cbInit <- io initMockWithoutCodebase - res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified tmp) ) + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp))) case res of CI.Error _ CI.NoCodebaseFoundAtSpecifiedDir -> expect True _ -> expect False ] + , scope "*with* a --codebase-create flag" $ tests + [ scope "a v2 codebase should be created when one does not exist at the Specified dir" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithoutCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) + case res of + CI.CreatedCodebase _ _ -> expect True + _ -> expect False + , + scope "a v2 codebase should be opened when one exists" do + tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") + cbInit <- io initMockWithCodebase + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) + case res of + CI.OpenedCodebase _ _ -> expect True + _ -> expect False + ] ] -- Test helpers diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 11d88e581d..1dec98b567 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -478,6 +478,7 @@ executable unison , unison-codebase-sync , unison-core1 , unison-parser-typechecker + , unliftio , uri-encode if flag(optimized) ghc-options: -funbox-strict-fields -O2 diff --git a/parser-typechecker/unison/ArgParse.hs b/parser-typechecker/unison/ArgParse.hs index c64421f974..1c167c69b0 100644 --- a/parser-typechecker/unison/ArgParse.hs +++ b/parser-typechecker/unison/ArgParse.hs @@ -74,6 +74,11 @@ data ShouldSaveCodebase | DontSaveCodebase deriving (Show, Eq) +data CodebasePathOption + = CreateCodebaseWhenMissing FilePath + | DontCreateCodebaseWhenMissing FilePath + deriving (Show, Eq) + data IsHeadless = Headless | WithCLI deriving (Show, Eq) @@ -84,6 +89,7 @@ data IsHeadless = Headless | WithCLI data Command = Launch IsHeadless CodebaseServerOpts | PrintVersion + -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released | Init | Run RunSource | Transcript ShouldForkCodebase ShouldSaveCodebase (NonEmpty FilePath ) @@ -91,7 +97,7 @@ data Command -- | Options shared by sufficiently many subcommands. data GlobalOptions = GlobalOptions - { codebasePath :: Maybe FilePath + { codebasePathOption :: Maybe CodebasePathOption } deriving (Show, Eq) -- | The root-level 'ParserInfo'. @@ -138,7 +144,8 @@ versionCommand = command "version" (info versionParser (fullDesc <> progDesc "Pr initCommand :: Mod CommandFields Command initCommand = command "init" (info initParser (progDesc initHelp)) where - initHelp = "Initialise a unison codebase" + initHelp = + "This command is has been removed. Use --codebase-create instead to create a codebase in the specified directory when starting the UCM." runSymbolCommand :: Mod CommandFields Command runSymbolCommand = @@ -190,18 +197,28 @@ commandParser envOpts = , transcriptForkCommand , launchHeadlessCommand envOpts ] - + globalOptionsParser :: Parser GlobalOptions globalOptionsParser = do -- ApplicativeDo - codebasePath <- codebasePathParser - pure GlobalOptions{..} + codebasePathOption <- codebasePathParser <|> codebaseCreateParser + + pure GlobalOptions{codebasePathOption = codebasePathOption} -codebasePathParser :: Parser (Maybe FilePath) -codebasePathParser = - optional . strOption $ +codebasePathParser :: Parser (Maybe CodebasePathOption) +codebasePathParser = do + optString <- optional . strOption $ long "codebase" - <> metavar "path/to/codebase" - <> help "The path to the codebase, defaults to the home directory" + <> metavar "codebase/path" + <> help "The path to an existing codebase" + pure (fmap DontCreateCodebaseWhenMissing optString) + +codebaseCreateParser :: Parser (Maybe CodebasePathOption) +codebaseCreateParser = do + path <- optional . strOption $ + long "codebase-create" + <> metavar "codebase/path" + <> help "The path to a new or existing codebase (one will be created if there isn't one)" + pure (fmap CreateCodebaseWhenMissing path) launchHeadlessCommand :: CodebaseServerOpts -> Mod CommandFields Command launchHeadlessCommand envOpts = @@ -249,7 +266,7 @@ launchParser envOpts isHeadless = do -- ApplicativeDo pure (Launch isHeadless codebaseServerOpts) initParser :: Parser Command -initParser = pure Init +initParser = pure Init versionParser :: Parser Command versionParser = pure PrintVersion diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 7571f5ed2f..1dcf815ce6 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -22,7 +22,7 @@ import qualified System.IO.Temp as Temp import qualified System.Path as Path import Text.Megaparsec (runParser) import qualified Unison.Codebase as Codebase -import Unison.Codebase.Init (InitResult(..), InitError(..)) +import Unison.Codebase.Init (InitResult(..), InitError(..), CodebaseInitOptions(..), SpecifiedCodebase(..)) import qualified Unison.Codebase.Init as CodebaseInit import qualified Unison.Codebase.Editor.Input as Input import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) @@ -42,14 +42,16 @@ import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import qualified Version +import UnliftIO.Directory ( getHomeDirectory ) import Compat ( installSignalHandlers ) import ArgParse ( UsageRenderer, - GlobalOptions(GlobalOptions, codebasePath), + GlobalOptions(GlobalOptions, codebasePathOption), Command(Launch, PrintVersion, Init, Run, Transcript), IsHeadless(WithCLI, Headless), ShouldSaveCodebase(..), ShouldForkCodebase(..), + CodebasePathOption(..), RunSource(RunFromPipe, RunFromSymbol, RunFromFile), parseCLIArgs ) import Data.List.NonEmpty (NonEmpty) @@ -62,8 +64,9 @@ main = do void installSignalHandlers (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribe - let GlobalOptions{codebasePath=mcodepath} = globalOptions - let cbInit = SC.init + let GlobalOptions{codebasePathOption=mCodePathOption} = globalOptions + let mcodepath = fmap codebasePathOptionToPath mCodePathOption + currentDir <- getCurrentDirectory configFilePath <- getConfigFilePath mcodepath config <- @@ -72,10 +75,21 @@ main = do case command of PrintVersion -> putStrLn $ progName ++ " version: " ++ Version.gitDescribe - Init -> - CodebaseInit.initCodebaseAndExit cbInit "main.init" mcodepath + Init -> do + PT.putPrettyLn $ + P.callout + "⚠️" + (P.lines ["The Init command has been removed" + , P.newline + , P.wrap "Use --codebase-create to create a codebase at a specified location and open it:" + , P.indentN 2 (P.hiBlue "$ ucm --codebase-create myNewCodebase") + , "Running UCM without the --codebase-create flag: " + , P.indentN 2 (P.hiBlue "$ ucm") + , P.wrap ("will " <> P.bold "always" <> " create a codebase in your home directory if one does not already exist.") + ]) + Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -86,7 +100,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing @@ -96,7 +110,7 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch @@ -105,9 +119,9 @@ main = do Nothing closeCodebase Transcript shouldFork shouldSaveCodebase transcriptFiles -> - runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mcodepath transcriptFiles + runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles Launch isHeadless codebaseServerOpts -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mcodepath + (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do case isHeadless of @@ -132,15 +146,16 @@ main = do launch currentDir config runtime theCodebase [] (Just baseUrl) closeCodebase -prepareTranscriptDir :: ShouldForkCodebase -> Maybe FilePath -> IO FilePath -prepareTranscriptDir shouldFork mcodepath = do +prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath +prepareTranscriptDir shouldFork mCodePathOption = do tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript") let cbInit = SC.init case shouldFork of UseFork -> do - getCodebaseOrExit mcodepath - path <- Codebase.getCodebaseDir mcodepath - PT.putPrettyLn $ P.lines [ + -- A forked codebase does not need to Create a codebase, because it already exists + getCodebaseOrExit mCodePathOption + path <- Codebase.getCodebaseDir (fmap codebasePathOptionToPath mCodePathOption) + PT.putPrettyLn $ P.lines [ P.wrap "Transcript will be run on a copy of the codebase at: ", "", P.indentN 2 (P.string path) ] @@ -168,7 +183,8 @@ runTranscripts' mcodepath transcriptDir args = do P.indentN 2 $ P.string err]) Right stanzas -> do configFilePath <- getConfigFilePath mcodepath - (closeCodebase, theCodebase) <- getCodebaseOrExit $ Just transcriptDir + -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. + (closeCodebase, theCodebase) <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -191,12 +207,12 @@ runTranscripts :: UsageRenderer -> ShouldForkCodebase -> ShouldSaveCodebase - -> Maybe FilePath + -> Maybe CodebasePathOption -> NonEmpty String -> IO () -runTranscripts renderUsageInfo shouldFork shouldSaveTempCodebase mcodepath args = do +runTranscripts renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption args = do progName <- getProgName - transcriptDir <- prepareTranscriptDir shouldFork mcodepath + transcriptDir <- prepareTranscriptDir shouldFork mCodePathOption completed <- runTranscripts' (Just transcriptDir) transcriptDir args case shouldSaveTempCodebase of @@ -260,13 +276,10 @@ defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) -getCodebaseOrExit :: Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann) -getCodebaseOrExit maybeSpecifiedDir = do - -- Likely we should only change codebase format 2? Or both? - -- Notes for selves: create a function 'openOrCreateCodebase' which handles v1/v2 codebase provided / no codebase specified - -- encode error messages as types. Our spike / idea is below: - codebaseDir <- CodebaseInit.homeOrSpecifiedDir maybeSpecifiedDir - CodebaseInit.openOrCreateCodebase SC.init "main" codebaseDir >>= \case +getCodebaseOrExit :: Maybe CodebasePathOption -> IO (IO (), Codebase.Codebase IO Symbol Ann) +getCodebaseOrExit codebasePathOption = do + initOptions <- codebasePathOptionToCodebaseInitOptions codebasePathOption + CodebaseInit.openOrCreateCodebase SC.init "main" initOptions >>= \case Error dir error -> let message = do @@ -275,10 +288,9 @@ getCodebaseOrExit maybeSpecifiedDir = do case error of NoCodebaseFoundAtSpecifiedDir -> - -- TODO: Perhaps prompt the user to create a codebase in that directory right away? pure (P.lines [ "No codebase exists in " <> pDir <> ".", - "Run `" <> executableName <> " --codebase " <> P.string dir <> " init` to create one, then try again!" + "Run `" <> executableName <> " --codebase-create" <> P.string dir <> " to create one, then try again!" ]) FoundV1Codebase -> @@ -305,3 +317,16 @@ getCodebaseOrExit maybeSpecifiedDir = do where prettyDir dir = P.string <$> canonicalizePath dir + +codebasePathOptionToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInit.CodebaseInitOptions +codebasePathOptionToCodebaseInitOptions option = + case option of + Just (CreateCodebaseWhenMissing path) -> pure $ Specified (CreateWhenMissing path) + Just (DontCreateCodebaseWhenMissing path) -> pure $ Specified (DontCreateWhenMissing path) + Nothing -> do Home <$> getHomeDirectory + +codebasePathOptionToPath :: CodebasePathOption -> FilePath +codebasePathOptionToPath codebasePathOption = + case codebasePathOption of + CreateCodebaseWhenMissing p -> p + DontCreateCodebaseWhenMissing p -> p \ No newline at end of file From 31dd5c4558f8f1e0064f42331e5a1df9d8ac7cc6 Mon Sep 17 00:00:00 2001 From: Stew O'Connor Date: Wed, 15 Sep 2021 12:50:34 -0700 Subject: [PATCH 082/148] reimplement Any functions directly instead of using the foreign calling convention --- .../src/Unison/Runtime/Builtin.hs | 20 ++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index d534ae06ef..5c7c6864ba 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -771,6 +771,17 @@ standard'handle instr where (h0,h) = fresh2 +any'construct :: Var v => SuperNormal v +any'construct + = unop0 0 $ \[v] + -> TCon Ty.anyRef 0 [v] + +any'extract :: Var v => SuperNormal v +any'extract + = unop0 1 + $ \[v,v1] -> TMatch v + $ MatchData Ty.anyRef (mapSingleton 0 $ ([BX], TAbs v1 (TVar v1))) Nothing + seek'handle :: ForeignOp seek'handle instr = ([BX,BX,BX],) @@ -1453,6 +1464,10 @@ builtinLookup , ("Code.lookup", code'lookup) , ("Value.load", value'load) , ("Value.value", value'create) + , ("Any.Any", any'construct) + , ("Any.unsafeExtract", any'extract) + + , ("STM.atomically", stm'atomic) ] ++ foreignWrappers @@ -1797,11 +1812,6 @@ declareForeigns = do declareForeign "Value.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeValue . Bytes.toArray - declareForeign "Any.Any" boxDirect . mkForeign $ \(a :: Closure) -> - pure $ Closure.DataB1 Ty.anyRef 0 a - - declareForeign "Any.unsafeExtract" boxDirect . mkForeign $ \(Closure.DataB1 _ _ a) -> pure $ a - -- Hashing functions let declareHashAlgorithm :: forall v alg . Var v => Hash.HashAlgorithm alg => Text -> alg -> FDecl v () declareHashAlgorithm txt alg = do From bcde3031c43abf34e361255f95b174096455f459 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 15 Sep 2021 21:26:39 -0400 Subject: [PATCH 083/148] wip --- parser-typechecker/src/Unison/Lexer.hs | 62 +++++++++++++++---- parser-typechecker/src/Unison/PrintError.hs | 4 ++ .../fix-2258-if-as-list-element.md | 10 +++ .../fix-2258-if-as-list-element.output.md | 7 +++ 4 files changed, 71 insertions(+), 12 deletions(-) create mode 100644 unison-src/transcripts/fix-2258-if-as-list-element.md create mode 100644 unison-src/transcripts/fix-2258-if-as-list-element.output.md diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 8466f103a7..cd34070d93 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -90,6 +90,7 @@ data Err | InvalidEscapeCharacter Char | LayoutError | CloseWithoutMatchingOpen String String -- open, close + | UnexpectedDelimiter String | Opaque String -- Catch-all failure type, generally these will be -- automatically generated errors coming from megaparsec -- Try to avoid this for common errors a user is likely to see. @@ -214,7 +215,8 @@ token'' tok p = do topHasClosePair :: Layout -> Bool topHasClosePair [] = False - topHasClosePair ((name,_):_) = name `elem` ["{", "(", "handle", "match", "if", "then"] + topHasClosePair ((name,_):_) = + name `elem` ["{", "(", "[", "handle", "match", "if", "then"] lexer0' :: String -> String -> [Token Lexeme] lexer0' scope rem = @@ -771,13 +773,29 @@ lexemes' eof = P.optional space >> do reserved :: P [Token Lexeme] reserved = - token' (\ts _ _ -> ts) $ - braces <|> parens <|> delim <|> delayOrForce <|> keywords <|> layoutKeywords - where - keywords = symbolyKw ":" <|> symbolyKw "@" <|> symbolyKw "||" <|> symbolyKw "|" <|> symbolyKw "&&" - <|> wordyKw "true" <|> wordyKw "false" - <|> wordyKw "use" <|> wordyKw "forall" <|> wordyKw "∀" - <|> wordyKw "termLink" <|> wordyKw "typeLink" + token' (\ts _ _ -> ts) + $ braces + <|> parens + <|> brackets + <|> commaSeparator + <|> delim + <|> delayOrForce + <|> keywords + <|> layoutKeywords + where + keywords = + symbolyKw ":" + <|> symbolyKw "@" + <|> symbolyKw "||" + <|> symbolyKw "|" + <|> symbolyKw "&&" + <|> wordyKw "true" + <|> wordyKw "false" + <|> wordyKw "use" + <|> wordyKw "forall" + <|> wordyKw "∀" + <|> wordyKw "termLink" + <|> wordyKw "typeLink" wordyKw s = separated wordySep (kw s) symbolyKw s = separated (not . symbolyIdChar) (kw s) @@ -809,12 +827,12 @@ lexemes' eof = P.optional space >> do let opens = [Token (Open "with") pos1 pos2] pure $ replicate n (Token Close pos1 pos2) ++ opens - -- In `structural/unique type` and `structural/unique ability`, + -- In `structural/unique type` and `structural/unique ability`, -- only the `structural` or `unique` opens a layout block, -- and `ability` and `type` are just keywords. openTypeKw1 t = do b <- S.gets (topBlockName . layout) - case b of + case b of Just mod | Set.member mod typeModifiers -> wordyKw t _ -> openKw1 wordySep t @@ -840,7 +858,7 @@ lexemes' eof = P.optional space >> do env <- S.get -- -> introduces a layout block if we're inside a `match with` or `cases` case topBlockName (layout env) of - Just match | match == "match-with" || match == "cases" -> do + Just match | match `elem` matchWithBlocks -> do S.put (env { opening = Just "->" }) pure [Token (Open "->") start end] _ -> pure [Token (Reserved "->") start end] @@ -854,7 +872,15 @@ lexemes' eof = P.optional space >> do inLayout <- S.gets inLayout when (not inLayout) $ void $ P.lookAhead (CP.satisfy (/= '}')) pure l + matchWithBlocks = ["match-with", "cases"] parens = open "(" <|> close ["("] (lit ")") + brackets = open "[" <|> close ["["] (lit "]") + commaSeparator = do + env <- S.get + case topBlockName (layout env) of + Just match | not (match `elem` matchWithBlocks) -> + blockDelimiter ["[", "("] (lit ",") + _ -> fail "this comma is a pattern separator" delim = P.try $ do ch <- CP.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) @@ -882,6 +908,18 @@ lexemes' eof = P.optional space >> do close = close' Nothing + blockDelimiter :: [String] -> P String -> P [Token Lexeme] + blockDelimiter open closeP = do + (pos1, close, pos2) <- positioned $ closeP + env <- S.get + case findClose open (layout env) of + Nothing -> err pos1 (UnexpectedDelimiter (quote close)) + where quote s = "'" <> s <> "'" + Just (block, n) -> do + S.put (env { layout = drop n (layout env), opening = Just block }) + let opens = [Token (Open block) pos1 pos2] + pure $ replicate n (Token Close pos1 pos2) ++ opens + close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] close' reopenBlockname open closeP = do (pos1, close, pos2) <- positioned $ closeP @@ -1086,7 +1124,7 @@ symbolyIdChars = Set.fromList "!$%^&*-=+<>.~\\/|:" keywords :: Set String keywords = Set.fromList [ "if", "then", "else", "forall", "∀", - "handle", "with", + "handle", "with", "where", "use", "true", "false", "alias", "typeLink", "termLink", diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 7575a83aaa..898c0c66dd 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -1031,6 +1031,10 @@ prettyParseError s = \case where excerpt = showSource s ((\t -> (rangeForToken t, ErrorSite)) <$> ts) go = \case + L.UnexpectedDelimiter s -> + "I found a " <> style ErrorSite (fromString s) <> + " here, but I didn't see a list or tuple that it might be a separator for.\n\n" <> + excerpt L.CloseWithoutMatchingOpen open close -> "I found a closing " <> style ErrorSite (fromString close) <> " here without a matching " <> style ErrorSite (fromString open) <> ".\n\n" <> diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/fix-2258-if-as-list-element.md new file mode 100644 index 0000000000..93e616025a --- /dev/null +++ b/unison-src/transcripts/fix-2258-if-as-list-element.md @@ -0,0 +1,10 @@ +Tests that `if` statements can appear as list elements. + +```ucm:hide +.> builtins.merge +``` + +```unison:hide +> [ if true then 1 else 0 ] +``` + diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md new file mode 100644 index 0000000000..d7451cc9cf --- /dev/null +++ b/unison-src/transcripts/fix-2258-if-as-list-element.output.md @@ -0,0 +1,7 @@ +Tests that `if` statements can appear as list elements. + +```unison +> [ if true then 1 else 0 + ] +``` + From a6abc66b3f2a9d9bf9c68f0bdc92acad6ab4283b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 16 Sep 2021 14:08:45 -0400 Subject: [PATCH 084/148] Add block closes to list and tuple commas --- parser-typechecker/src/Unison/Lexer.hs | 6 ++-- parser-typechecker/src/Unison/Parser.hs | 27 +++++++++++------ .../fix-2258-if-as-list-element.md | 27 ++++++++++++++++- .../fix-2258-if-as-list-element.output.md | 30 +++++++++++++++++-- 4 files changed, 74 insertions(+), 16 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index cd34070d93..88f8c7eab4 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -911,14 +911,14 @@ lexemes' eof = P.optional space >> do blockDelimiter :: [String] -> P String -> P [Token Lexeme] blockDelimiter open closeP = do (pos1, close, pos2) <- positioned $ closeP - env <- S.get + env <- S.get case findClose open (layout env) of Nothing -> err pos1 (UnexpectedDelimiter (quote close)) where quote s = "'" <> s <> "'" Just (block, n) -> do S.put (env { layout = drop n (layout env), opening = Just block }) - let opens = [Token (Open block) pos1 pos2] - pure $ replicate n (Token Close pos1 pos2) ++ opens + let opens = [Token (Reserved close) pos1 pos2] + pure $ replicate (n-1) (Token Close pos1 pos2) ++ opens close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] close' reopenBlockname open closeP = do diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 374124b573..8659079793 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -408,7 +408,7 @@ string = queryToken getString tupleOrParenthesized :: Ord v => P v a -> (Ann -> a) -> (a -> a -> a) -> P v a tupleOrParenthesized p unit pair = do open <- openBlockWith "(" - es <- sepBy (reserved "," *> optional semi) p + es <- sepBy (reserved ",") p close <- optional semi *> closeBlock pure $ go es open close where @@ -416,14 +416,23 @@ tupleOrParenthesized p unit pair = do go as s e = foldr pair (unit (ann s <> ann e)) as seq :: Ord v => (Ann -> [a] -> a) -> P v a -> P v a -seq f p = f' <$> leading <*> elements <*> trailing - where - f' open elems close = f (ann open <> ann close) elems - redundant = P.skipMany (P.eitherP (reserved ",") semi) - leading = reserved "[" <* redundant - trailing = redundant *> reserved "]" - sep = P.try $ optional semi *> reserved "," <* redundant - elements = sepEndBy sep p +seq f p = do + open <- openBlockWith "[" + es <- sepBy (reserved ",") p + close <- optional semi *> closeBlock + pure $ go open es close + where + go open elems close = f (ann open <> ann close) elems + +-- seq :: Ord v => (Ann -> [a] -> a) -> P v a -> P v a +-- seq f p = f' <$> leading <*> elements <*> trailing +-- where +-- f' open elems close = f (ann open <> ann close) elems +-- redundant = P.skipMany (P.eitherP (reserved ",") semi) +-- leading = openBlockWith "[" <* redundant +-- trailing = redundant *> reserved "]" +-- sep = P.try $ optional semi *> reserved "," <* redundant +-- elements = sepEndBy sep p chainr1 :: Ord v => P v a -> P v (a -> a -> a) -> P v a chainr1 p op = go1 where diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/fix-2258-if-as-list-element.md index 93e616025a..805a82037f 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.md @@ -1,4 +1,4 @@ -Tests that `if` statements can appear as list elements. +Tests that `if` statements can appear as list and tuple elements. ```ucm:hide .> builtins.merge @@ -6,5 +6,30 @@ Tests that `if` statements can appear as list elements. ```unison:hide > [ if true then 1 else 0 ] + +> [ if true then 1 else 0, 1] + +> [1, if true then 1 else 0] + +> (if true then 1 else 0, 0) + +> (0, if true then 1 else 0) + +> (1) + +> (1,2) + +> (1,2,3) + +> [1,2,3] + +> [] + +> [1] + +> [1,2] + +> [1,2,3] + ``` diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md index d7451cc9cf..388dea4d9d 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.output.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.output.md @@ -1,7 +1,31 @@ -Tests that `if` statements can appear as list elements. +Tests that `if` statements can appear as list and tuple elements. ```unison -> [ if true then 1 else 0 - ] +> [ if true then 1 else 0 ] + +> [ if true then 1 else 0, 1] + +> [1, if true then 1 else 0] + +> (if true then 1 else 0, 0) + +> (0, if true then 1 else 0) + +> (1) + +> (1,2) + +> (1,2,3) + +> [1,2,3] + +> [] + +> [1] + +> [1,2] + +> [1,2,3] + ``` From 9a569dc4b02b60f87a7d0672245814718ba21ef7 Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 16 Sep 2021 12:12:37 -0700 Subject: [PATCH 085/148] Adds the --no-base flag option for initializing new codebase --- parser-typechecker/.DS_Store | Bin 0 -> 6148 bytes .../src/Unison/Codebase/Init.hs | 6 +-- .../src/Unison/CommandLine/Main.hs | 11 ++-- .../src/Unison/CommandLine/Welcome.hs | 30 ++++++----- .../tests/Unison/Test/CodebaseInit.hs | 14 ++--- parser-typechecker/unison/ArgParse.hs | 15 +++++- parser-typechecker/unison/Main.hs | 48 +++++++++++------- 7 files changed, 74 insertions(+), 50 deletions(-) create mode 100644 parser-typechecker/.DS_Store diff --git a/parser-typechecker/.DS_Store b/parser-typechecker/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..949ebd51bf74f6fd18ae3e5f0e5326d13a9e4d68 GIT binary patch literal 6148 zcmeHK%}N6?5Kh`!vlX!i!5;VGt%v@I*n_aF_25ld(Su66ON(8oo6_A{w65%H=o|S2 zzK%0VS}4_n7ZE!HlW#JaNyxWLCSis4J2)9z?F@kSq$O z@hBL|U?rLye~|(Fc11Q}5er$&mcQS7FdBw&QmcLNT)wbT+!UfDO53GdZy={$;wO{X z^~cxPJNJ`8VC)MihYQ;eF2nw`Q{Fw1QR0VDf2@+jULQhkuEMA%r>>kty;#lT=>Z`u zVRg!t*{sp3RqbZ|D6QJFRs-yV=3$yzVsF2GeAc~xe40I{FRz+e4nLui9fNat17m5E z58gN$%IFUK^PG7sAu&J<5Cdz#fI0fa)*9@Uwnz*R13zN`&j%Y6(J`25R7VFiczwk2 z0wN07_?AGl4LSxhjW7bjbt<4v<>raObvpQM6XzJrH0pH5)ygoBS(%#`3RkOx-&Wy_ zI~u7a28e-W2J*UF#`=Hy{ri78iF(8UG4QV#;Dxr=c414VwytarYpo611x3NQOyeR2 j3{{FD7E5sjR0;TPGyolgnMUw{&_zJeKn*eQs|v literal 0 HcmV?d00001 diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 3e72902a3b..cc9784d1b5 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -96,9 +96,9 @@ openOrCreateCodebase cbInit debugName initOptions = do createCodebaseWithResult cbInit debugName homeDir ) - Specified specificed -> - whenNoV1Codebase (initOptionsToDir initOptions) $ do - case specificed of + Specified specified -> + whenNoV1Codebase resolvedPath $ do + case specified of DontCreateWhenMissing dir -> pure (Error dir NoCodebaseFoundAtSpecifiedDir) CreateWhenMissing dir -> diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index d08441b646..2f10517a53 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -20,13 +20,12 @@ import qualified Unison.Server.CodebaseServer as Server import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import Unison.Codebase.Editor.Command (LoadSourceResult(..)) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase (Codebase) import Unison.CommandLine import Unison.PrettyTerminal import Unison.CommandLine.InputPattern (ArgumentType (suggestions), InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) -import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered, shortenDirectory) +import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) import Unison.Parser.Ann (Ann) import Unison.Symbol (Symbol) import qualified Control.Concurrent.Async as Async @@ -106,19 +105,17 @@ getUserInput patterns codebase branch currentPath numberedArgs = Line.runInputT main :: FilePath - -> Maybe ReadRemoteNamespace + -> Welcome.Welcome -> Path.Absolute -> (Config, IO ()) -> [Either Event Input] -> Runtime.Runtime Symbol -> Codebase IO Symbol Ann - -> String -> Maybe Server.BaseUrl -> IO () -main dir defaultBaseLib initialPath (config, cancelConfig) initialInputs runtime codebase version serverBaseUrl = do - dir' <- shortenDirectory dir +main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - (welcomeCmds, welcomeMsg) <- Welcome.welcome defaultBaseLib codebase dir' version + (welcomeCmds, welcomeMsg) <- Welcome.welcome codebase welcome putPrettyLn welcomeMsg eventQueue <- Q.newIO do diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 4d6ae6fd6d..e593f18a7a 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -14,20 +14,26 @@ import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -welcome - :: Maybe ReadRemoteNamespace - -> Codebase IO v a - -> FilePath - -> String - -> IO ([Either Event Input], P.Pretty P.ColorText) -welcome defaultBaseLib codebase dir version = do +-- Should Welcome include whether or not the codebase was created just now? + +data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase + +data Welcome = Welcome + { downloadBase :: DownloadBase + , watchDir :: FilePath + , unisonVersion :: String + } + +welcome :: Codebase IO v a -> Welcome -> IO ([Either Event Input], P.Pretty P.ColorText) +welcome codebase welcome' = do + let Welcome{downloadBase=downloadBase, watchDir=dir, unisonVersion=version} = welcome' welcomeMsg <- welcomeMessage dir version isBlankCodebase <- Codebase.isBlank codebase - pure $ case defaultBaseLib of - Just ns@(_, _, path) | isBlankCodebase -> + pure $ case downloadBase of + DownloadBase ns@(_, _, path) | isBlankCodebase -> let cmd = - Right (downloadBase ns) + Right (pullBase ns) baseVersion = P.string (show path) @@ -70,8 +76,8 @@ welcomeMessage dir version = do ) ] -downloadBase :: ReadRemoteNamespace -> Input -downloadBase ns = do +pullBase :: ReadRemoteNamespace -> Input +pullBase ns = do let seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } diff --git a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs index 06be3ffdac..d909b15e6d 100644 --- a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs +++ b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs @@ -8,7 +8,7 @@ import EasyTest import qualified Unison.Codebase.Init as CI import Unison.Codebase.Init ( CodebaseInitOptions(..) - , Init(..) + , Init(..) , SpecifiedCodebase(..) ) import qualified System.IO.Temp as Temp @@ -32,7 +32,7 @@ test = scope "Codebase.Init" $ tests , scope "a v2 codebase should be created when one does not exist" do tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") cbInit <- io initMockWithoutCodebase - res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp) ) + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp)) case res of CI.CreatedCodebase _ _ -> expect True _ -> expect False @@ -57,7 +57,7 @@ test = scope "Codebase.Init" $ tests [ scope "a v2 codebase should be created when one does not exist at the Specified dir" do tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test") cbInit <- io initMockWithoutCodebase - res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) + res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) case res of CI.CreatedCodebase _ _ -> expect True _ -> expect False @@ -79,9 +79,9 @@ initMockWithCodebase = do let codebase = error "did we /actually/ need a Codebase?" pure $ Init { -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), - openCodebase = (\_ _ -> pure ( Right (pure (), codebase))), + openCodebase = \_ _ -> pure ( Right (pure (), codebase)), -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), - createCodebase' = (\_ _ -> pure (Right (pure (), codebase))), + createCodebase' = \_ _ -> pure (Right (pure (), codebase)), -- CodebasePath -> CodebasePath codebasePath = id } @@ -91,9 +91,9 @@ initMockWithoutCodebase = do let codebase = error "did we /actually/ need a Codebase?" pure $ Init { -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), - openCodebase = (\_ _ -> pure (Left "no codebase found")), + openCodebase = \_ _ -> pure (Left "no codebase found"), -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), - createCodebase' = (\_ _ -> pure (Right (pure (), codebase))), + createCodebase' = \_ _ -> pure (Right (pure (), codebase)), -- CodebasePath -> CodebasePath codebasePath = id } \ No newline at end of file diff --git a/parser-typechecker/unison/ArgParse.hs b/parser-typechecker/unison/ArgParse.hs index 1c167c69b0..632a2ae1dd 100644 --- a/parser-typechecker/unison/ArgParse.hs +++ b/parser-typechecker/unison/ArgParse.hs @@ -69,6 +69,11 @@ data ShouldForkCodebase | DontFork deriving (Show, Eq) +data ShouldDownloadBase + = ShouldDownloadBase + | ShouldNotDownloadBase + deriving (Show, Eq) + data ShouldSaveCodebase = SaveCodebase | DontSaveCodebase @@ -87,7 +92,7 @@ data IsHeadless = Headless | WithCLI -- Note that this is not one-to-one with command-parsers since some are simple variants. -- E.g. run, run.file, run.pipe data Command - = Launch IsHeadless CodebaseServerOpts + = Launch IsHeadless CodebaseServerOpts ShouldDownloadBase | PrintVersion -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released | Init @@ -263,7 +268,8 @@ codebaseServerOptsParser envOpts = do -- ApplicativeDo launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command launchParser envOpts isHeadless = do -- ApplicativeDo codebaseServerOpts <- codebaseServerOptsParser envOpts - pure (Launch isHeadless codebaseServerOpts) + downloadBase <- downloadBaseFlag + pure (Launch isHeadless codebaseServerOpts downloadBase) initParser :: Parser Command initParser = pure Init @@ -290,6 +296,11 @@ saveCodebaseFlag = flag DontSaveCodebase SaveCodebase (long "save-codebase" <> h where saveHelp = "if set the resulting codebase will be saved to a new directory, otherwise it will be deleted" +downloadBaseFlag :: Parser ShouldDownloadBase +downloadBaseFlag = flag ShouldDownloadBase ShouldNotDownloadBase (long "no-base" <> help downloadBaseHelp) + where + downloadBaseHelp = "if set, a new codebase will be created without downloading the base library, otherwise the new codebase will download base" + fileArgument :: String -> Parser FilePath fileArgument varName = strArgument ( metavar varName diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 1dcf815ce6..5e9cfa890d 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -32,6 +32,7 @@ import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SqliteCodebase as SC import qualified Unison.Codebase.TranscriptParser as TR import Unison.CommandLine (plural', watchConfig) +import qualified Unison.CommandLine.Welcome as Welcome import qualified Unison.CommandLine.Main as CommandLine import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -51,6 +52,7 @@ import ArgParse IsHeadless(WithCLI, Headless), ShouldSaveCodebase(..), ShouldForkCodebase(..), + ShouldDownloadBase (..), CodebasePathOption(..), RunSource(RunFromPipe, RunFromSymbol, RunFromFile), parseCLIArgs ) @@ -103,7 +105,7 @@ main = do (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing + launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing ShouldNotDownloadBase closeCodebase Run (RunFromPipe mainName) -> do e <- safeReadUtf8StdIn @@ -117,10 +119,11 @@ main = do currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing + ShouldNotDownloadBase closeCodebase Transcript shouldFork shouldSaveCodebase transcriptFiles -> runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles - Launch isHeadless codebaseServerOpts -> do + Launch isHeadless codebaseServerOpts downloadBase -> do (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do @@ -143,7 +146,7 @@ main = do takeMVar mvar WithCLI -> do PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." - launch currentDir config runtime theCodebase [] (Just baseUrl) + launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase closeCodebase prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath @@ -242,18 +245,25 @@ launch -> Codebase.Codebase IO Symbol Ann -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl + -> ShouldDownloadBase -> IO () -launch dir config runtime codebase inputs serverBaseUrl = - CommandLine.main - dir - defaultBaseLib - initialPath - config - inputs - runtime - codebase - Version.gitDescribe - serverBaseUrl +launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase = + let + downloadBase = case defaultBaseLib of + Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS + _ -> Welcome.DontDownloadBase + + welcome = Welcome.Welcome downloadBase dir Version.gitDescribe + in + CommandLine.main + dir + welcome + initialPath + config + inputs + runtime + codebase + serverBaseUrl isMarkdown :: String -> Bool isMarkdown md = case FP.takeExtension md of @@ -278,7 +288,7 @@ defaultBaseLib = rightMay $ getCodebaseOrExit :: Maybe CodebasePathOption -> IO (IO (), Codebase.Codebase IO Symbol Ann) getCodebaseOrExit codebasePathOption = do - initOptions <- codebasePathOptionToCodebaseInitOptions codebasePathOption + initOptions <- argsToCodebaseInitOptions codebasePathOption CodebaseInit.openOrCreateCodebase SC.init "main" initOptions >>= \case Error dir error -> let @@ -290,7 +300,7 @@ getCodebaseOrExit codebasePathOption = do NoCodebaseFoundAtSpecifiedDir -> pure (P.lines [ "No codebase exists in " <> pDir <> ".", - "Run `" <> executableName <> " --codebase-create" <> P.string dir <> " to create one, then try again!" + "Run `" <> executableName <> " --codebase-create " <> P.string dir <> " to create one, then try again!" ]) FoundV1Codebase -> @@ -318,9 +328,9 @@ getCodebaseOrExit codebasePathOption = do where prettyDir dir = P.string <$> canonicalizePath dir -codebasePathOptionToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInit.CodebaseInitOptions -codebasePathOptionToCodebaseInitOptions option = - case option of +argsToCodebaseInitOptions :: Maybe CodebasePathOption -> IO CodebaseInit.CodebaseInitOptions +argsToCodebaseInitOptions pathOption = + case pathOption of Just (CreateCodebaseWhenMissing path) -> pure $ Specified (CreateWhenMissing path) Just (DontCreateCodebaseWhenMissing path) -> pure $ Specified (DontCreateWhenMissing path) Nothing -> do Home <$> getHomeDirectory From be3b9919ec6c1d930c216ff05f79531ce0f4f765 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 16 Sep 2021 22:35:15 -0400 Subject: [PATCH 086/148] Fix up types and corner cases --- parser-typechecker/src/Unison/FileParser.hs | 2 +- parser-typechecker/src/Unison/Lexer.hs | 2 +- parser-typechecker/src/Unison/Parser.hs | 37 +++++++------------ parser-typechecker/src/Unison/TypeParser.hs | 4 +- .../fix-2258-if-as-list-element.md | 16 ++++++++ .../fix-2258-if-as-list-element.output.md | 16 ++++++++ 6 files changed, 49 insertions(+), 28 deletions(-) diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index 925d61448d..e0ff8f554c 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -230,7 +230,7 @@ modifier = do unique = do tok <- openBlockWith "unique" uid <- do - o <- optional (reserved "[" *> wordyIdString <* reserved "]") + o <- optional (openBlockWith "[" *> wordyIdString <* closeBlock) case o of Nothing -> uniqueName 32 Just uid -> pure (fromString . L.payload $ uid) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 88f8c7eab4..5f1cf7cb76 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -878,7 +878,7 @@ lexemes' eof = P.optional space >> do commaSeparator = do env <- S.get case topBlockName (layout env) of - Just match | not (match `elem` matchWithBlocks) -> + Just match | not (match `elem` matchWithBlocks || match == "{") -> blockDelimiter ["[", "("] (lit ",") _ -> fail "this comma is a pattern separator" diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 8659079793..c718041a50 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -406,33 +406,22 @@ string = queryToken getString getString _ = Nothing tupleOrParenthesized :: Ord v => P v a -> (Ann -> a) -> (a -> a -> a) -> P v a -tupleOrParenthesized p unit pair = do - open <- openBlockWith "(" - es <- sepBy (reserved ",") p - close <- optional semi *> closeBlock - pure $ go es open close - where - go [t] _ _ = t - go as s e = foldr pair (unit (ann s <> ann e)) as +tupleOrParenthesized p unit pair = seq' "(" go p + where + go _ [t] = t + go a xs = foldr pair (unit a) xs seq :: Ord v => (Ann -> [a] -> a) -> P v a -> P v a -seq f p = do - open <- openBlockWith "[" - es <- sepBy (reserved ",") p - close <- optional semi *> closeBlock +seq = seq' "[" + +seq' :: Ord v => String -> (Ann -> [a] -> a) -> P v a -> P v a +seq' openStr f p = do + open <- openBlockWith openStr <* redundant + es <- sepEndBy (reserved ",") p + close <- redundant *> closeBlock pure $ go open es close - where - go open elems close = f (ann open <> ann close) elems - --- seq :: Ord v => (Ann -> [a] -> a) -> P v a -> P v a --- seq f p = f' <$> leading <*> elements <*> trailing --- where --- f' open elems close = f (ann open <> ann close) elems --- redundant = P.skipMany (P.eitherP (reserved ",") semi) --- leading = openBlockWith "[" <* redundant --- trailing = redundant *> reserved "]" --- sep = P.try $ optional semi *> reserved "," <* redundant --- elements = sepEndBy sep p + where go open elems close = f (ann open <> ann close) elems + redundant = P.skipMany (P.eitherP (reserved ",") semi) chainr1 :: Ord v => P v a -> P v (a -> a -> a) -> P v a chainr1 p op = go1 where diff --git a/parser-typechecker/src/Unison/TypeParser.hs b/parser-typechecker/src/Unison/TypeParser.hs index 8dab497b67..6ace791bc8 100644 --- a/parser-typechecker/src/Unison/TypeParser.hs +++ b/parser-typechecker/src/Unison/TypeParser.hs @@ -84,9 +84,9 @@ effectList = do sequenceTyp :: Var v => TypeP v sequenceTyp = do - open <- reserved "[" + open <- openBlockWith "[" t <- valueType - close <- reserved "]" + close <- closeBlock let a = ann open <> ann close pure $ Type.app a (Type.list a) t diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/fix-2258-if-as-list-element.md index 805a82037f..ab42937130 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.md @@ -31,5 +31,21 @@ Tests that `if` statements can appear as list and tuple elements. > [1,2,3] +> [ + 1, + 2, + 3 + ] + +> [ + 1, + 2, + 3,] + +> (1,2,3,) + +> (1, + 2,) + ``` diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md index 388dea4d9d..5058437f94 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.output.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.output.md @@ -27,5 +27,21 @@ Tests that `if` statements can appear as list and tuple elements. > [1,2,3] +> [ + 1, + 2, + 3 + ] + +> [ + 1, + 2, + 3,] + +> (1,2,3,) + +> (1, + 2,) + ``` From c07bb0d61916bb8b7151595493aa98e3c09114dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 16 Sep 2021 23:03:53 -0400 Subject: [PATCH 087/148] Allow inner redundant commas (for some reason) --- parser-typechecker/src/Unison/Parser.hs | 2 +- parser-typechecker/tests/Unison/Test/Lexer.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index c718041a50..14e4cffe37 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -417,7 +417,7 @@ seq = seq' "[" seq' :: Ord v => String -> (Ann -> [a] -> a) -> P v a -> P v a seq' openStr f p = do open <- openBlockWith openStr <* redundant - es <- sepEndBy (reserved ",") p + es <- sepEndBy (P.try $ optional semi *> reserved "," <* redundant) p close <- redundant *> closeBlock pure $ go open es close where go open elems close = f (ann open <> ann close) elems diff --git a/parser-typechecker/tests/Unison/Test/Lexer.hs b/parser-typechecker/tests/Unison/Test/Lexer.hs index b1cd43212b..a048309bcf 100644 --- a/parser-typechecker/tests/Unison/Test/Lexer.hs +++ b/parser-typechecker/tests/Unison/Test/Lexer.hs @@ -64,10 +64,10 @@ test = , t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close] , t "[+1,+1]" - [Reserved "[", Numeric "+1", Reserved ",", Numeric "+1", Reserved "]"] + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close ] , t "[ +1 , +1 ]" - [Reserved "[", Numeric "+1", Reserved ",", Numeric "+1", Reserved "]"] + [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close ] , t "-- a comment 1.0" [] , t "\"woot\" -- a comment 1.0" [Textual "woot"] , t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"] From eb46a884b3b4409f6fc99240ecf9cc829e3d9e67 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 17 Sep 2021 08:24:37 -0500 Subject: [PATCH 088/148] added extra test of more corner cases --- .../transcripts/fix-2258-if-as-list-element.md | 15 +++++++++++++++ .../fix-2258-if-as-list-element.output.md | 15 +++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.md b/unison-src/transcripts/fix-2258-if-as-list-element.md index ab42937130..fbf9cc93dd 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.md @@ -47,5 +47,20 @@ Tests that `if` statements can appear as list and tuple elements. > (1, 2,) +structural ability Zoot where zoot : () + +Zoot.handler : Request {Zoot} a -> a +Zoot.handler = cases + { a } -> a + { zoot -> k } -> handle !k with Zoot.handler + +fst = cases (x,_) -> x + +> List.size + [ if true then (x y -> y) + else handle (x y -> x) with fst (Zoot.handler, 42), + cases a, b -> a Nat.+ b, -- multi-arg cases lambda + cases x, y -> x Nat.+ y + ] ``` diff --git a/unison-src/transcripts/fix-2258-if-as-list-element.output.md b/unison-src/transcripts/fix-2258-if-as-list-element.output.md index 5058437f94..50c28c0046 100644 --- a/unison-src/transcripts/fix-2258-if-as-list-element.output.md +++ b/unison-src/transcripts/fix-2258-if-as-list-element.output.md @@ -43,5 +43,20 @@ Tests that `if` statements can appear as list and tuple elements. > (1, 2,) +structural ability Zoot where zoot : () + +Zoot.handler : Request {Zoot} a -> a +Zoot.handler = cases + { a } -> a + { zoot -> k } -> handle !k with Zoot.handler + +fst = cases (x,_) -> x + +> List.size + [ if true then (x y -> y) + else handle (x y -> x) with fst (Zoot.handler, 42), + cases a, b -> a Nat.+ b, -- multi-arg cases lambda + cases x, y -> x Nat.+ y + ] ``` From d6ae87716b29067db3895f47f49c1d418a3c57b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 14 Sep 2021 11:21:37 -0400 Subject: [PATCH 089/148] Add transcript for records pretty printing --- unison-src/transcripts/records.md | 70 +++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 unison-src/transcripts/records.md diff --git a/unison-src/transcripts/records.md b/unison-src/transcripts/records.md new file mode 100644 index 0000000000..ab1bb4c998 --- /dev/null +++ b/unison-src/transcripts/records.md @@ -0,0 +1,70 @@ +Ensure that Records keep their syntax after being added to the codebase + +```ucm:hide +.> builtins.mergeio +.> load unison-src/transcripts-using-base/base.u +``` + +## Record with 1 field + +```unison:hide +unique type Record1 = { a : Text } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record1 +``` + +## Record with 2 fields + +```unison:hide +unique type Record2 = { a : Text, b : Int } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record2 +``` + +## Record with 3 fields + +```unison:hide +unique type Record3 = { a : Text, b : Int, c : Nat } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record3 +``` + +## Record with many fields + +```unison:hide +unique type Record4 = + { a : Text + , b : Int + , c : Nat + , d : Bytes + , e : Text + , f : Nat + , g : [Nat] + } +``` + +```ucm:hide +.> add +``` + +```ucm +.> view Record4 +``` From 16201809f5e2b1ed5fcd1e62c70695d8452246e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 14 Sep 2021 11:43:00 -0400 Subject: [PATCH 090/148] Fix records to print with fieldnames We were attempting to determine a type being a records, by looking number of accessors and seeing if they matched a freshly generated number of them. This was not working as we too eagerly removed type prefixed names thus causing a mismatch. --- .../src/Unison/CommandLine/DisplayValues.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 2 +- parser-typechecker/src/Unison/DeclPrinter.hs | 26 ++++---- .../src/Unison/PrettyPrintEnv/Util.hs | 7 +- .../src/Unison/PrettyPrintEnvDecl.hs | 3 +- .../src/Unison/Server/Backend.hs | 5 +- parser-typechecker/src/Unison/Server/Doc.hs | 2 +- unison-src/transcripts/records.output.md | 65 +++++++++++++++++++ 8 files changed, 90 insertions(+), 22 deletions(-) create mode 100644 unison-src/transcripts/records.output.md diff --git a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs index 32ea85e3f0..cd5dfa6ab3 100644 --- a/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs +++ b/parser-typechecker/src/Unison/CommandLine/DisplayValues.hs @@ -312,7 +312,7 @@ displayDoc pped terms typeOf evaluated types = go Referent.Con r _ _ -> prettyType r prettyType r = let ppe = PPE.declarationPPE pped r in types r >>= \case Nothing -> pure $ "😶 Missing type source for: " <> typeName ppe r - Just ty -> pure . P.syntaxToColor $ P.group $ DP.prettyDecl ppe r (PPE.typeName ppe r) ty + Just ty -> pure . P.syntaxToColor $ P.group $ DP.prettyDecl pped r (PPE.typeName ppe r) ty termName :: PPE.PrettyPrintEnv -> Referent -> Pretty termName ppe r = P.syntaxToColor $ diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 5817d0ddd4..182b9a3e6f 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -1150,7 +1150,7 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp BuiltinObject _ -> builtin n UserObject decl -> case decl of Left d -> DeclPrinter.prettyEffectDecl (ppeBody r) r n d - Right d -> DeclPrinter.prettyDataDecl (ppeBody r) r n d + Right d -> DeclPrinter.prettyDataDecl (PPE.declarationPPEDecl ppe0 r) r n d builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in." missing n r = P.wrap ( "-- The name " <> prettyHashQualified n <> " is assigned to the " diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index 070c0af1a6..4f11fbba51 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -19,6 +19,7 @@ import qualified Unison.Name as Name import Unison.Name ( Name ) import Unison.NamePrinter ( styleHashQualified'' ) import Unison.PrettyPrintEnv ( PrettyPrintEnv ) +import Unison.PrettyPrintEnvDecl ( PrettyPrintEnvDecl(..) ) import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import Unison.Reference ( Reference(DerivedId) ) @@ -35,13 +36,13 @@ type SyntaxText = S.SyntaxText' Reference prettyDecl :: Var v - => PrettyPrintEnv + => PrettyPrintEnvDecl -> Reference -> HashQualified Name -> DD.Decl v a -> Pretty SyntaxText -prettyDecl ppe r hq d = case d of - Left e -> prettyEffectDecl ppe r hq e +prettyDecl ppe@(PrettyPrintEnvDecl unsuffixifiedPPE _) r hq d = case d of + Left e -> prettyEffectDecl unsuffixifiedPPE r hq e Right dd -> prettyDataDecl ppe r hq dd prettyEffectDecl @@ -88,12 +89,12 @@ prettyPattern env ctorType ref namespace cid = styleHashQualified'' prettyDataDecl :: Var v - => PrettyPrintEnv + => PrettyPrintEnvDecl -> Reference -> HashQualified Name -> DataDeclaration v a -> Pretty SyntaxText -prettyDataDecl env r name dd = +prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd = (header <>) . P.sep (fmt S.DelimiterChar (" | " `P.orElse` "\n | ")) $ constructor <$> zip [0 ..] (DD.constructors' dd) @@ -101,16 +102,16 @@ prettyDataDecl env r name dd = constructor (n, (_, _, (Type.ForallsNamed' _ t))) = constructor' n t constructor (n, (_, _, t) ) = constructor' n t constructor' n t = case Type.unArrows t of - Nothing -> prettyPattern env CT.Data r name n - Just ts -> case fieldNames env r name dd of - Nothing -> P.group . P.hang' (prettyPattern env CT.Data r name n) " " - $ P.spaced (TypePrinter.prettyRaw env Map.empty 10 <$> init ts) + Nothing -> prettyPattern suffixifiedPPE CT.Data r name n + Just ts -> case fieldNames unsuffixifiedPPE r name dd of + Nothing -> P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data r name n) " " + $ P.spaced (TypePrinter.prettyRaw suffixifiedPPE Map.empty 10 <$> init ts) Just fs -> P.group $ (fmt S.DelimiterChar "{ ") <> P.sep ((fmt S.DelimiterChar ",") <> " " `P.orElse` "\n ") (field <$> zip fs (init ts)) <> (fmt S.DelimiterChar " }") field (fname, typ) = P.group $ styleHashQualified'' (fmt (S.Reference r)) fname <> - (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw env Map.empty (-1) typ + (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw suffixifiedPPE Map.empty (-1) typ header = prettyDataHeader name dd <> (fmt S.DelimiterChar (" = " `P.orElse` "\n = ")) -- Comes up with field names for a data declaration which has the form of a @@ -144,12 +145,11 @@ fieldNames env r name dd = case DD.constructors dd of fieldNames = Map.fromList [ (r, f) | (r, n) <- names , typename <- pure (HQ.toString name) - , typename `isPrefixOf` n - -- drop the typename and the following '.' + , typename `isPrefixOf` (traceShowId n) , rest <- pure $ drop (length typename + 1) n , (f, rest) <- pure $ span (/= '.') rest , rest `elem` ["",".set",".modify"] ] - in if Map.size fieldNames == length names then + in if traceShowId (Map.size fieldNames) == traceShowId (length names) then Just [ HQ.unsafeFromString name | v <- vars , Just (ref, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes] diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs index 0dd8db24f3..f7dbff52e4 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.PrettyPrintEnv.Util (declarationPPE) where +module Unison.PrettyPrintEnv.Util (declarationPPE, declarationPPEDecl) where import qualified Data.Set as Set import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) @@ -29,3 +29,8 @@ declarationPPE ppe rd = PrettyPrintEnv tm ty if Set.member r comp then types (unsuffixifiedPPE ppe) r else types (suffixifiedPPE ppe) r + +-- The suffixed names uses the fully-qualified name for `r` +declarationPPEDecl :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnvDecl +declarationPPEDecl ppe r = + ppe { suffixifiedPPE = declarationPPE ppe r } \ No newline at end of file diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs index 92b788d9ad..340fae4c78 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs @@ -2,7 +2,7 @@ module Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl(..)) where -import Unison.PrettyPrintEnv (PrettyPrintEnv) +import Unison.PrettyPrintEnv (PrettyPrintEnv(..)) -- A pair of PrettyPrintEnvs: -- - suffixifiedPPE uses the shortest unique suffix @@ -16,3 +16,4 @@ data PrettyPrintEnvDecl = PrettyPrintEnvDecl { unsuffixifiedPPE :: PrettyPrintEnv, suffixifiedPPE :: PrettyPrintEnv } deriving Show + diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 5dafb99534..a761b76e31 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -890,9 +890,6 @@ typesToSyntax suff width ppe0 types = (first (PPE.typeName ppeDecl) . dupe) types where - ppeBody r = if suffixified suff - then PPE.suffixifiedPPE ppe0 - else PPE.declarationPPE ppe0 r ppeDecl = if suffixified suff then PPE.suffixifiedPPE ppe0 else PPE.unsuffixifiedPPE ppe0 @@ -900,7 +897,7 @@ typesToSyntax suff width ppe0 types = BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) MissingObject sh -> MissingObject sh UserObject d -> UserObject . Pretty.render width $ - DeclPrinter.prettyDecl (ppeBody r) r n d + DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d loadSearchResults :: (Var v, Applicative m) diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index a1c0a1a61d..d00b868066 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -244,7 +244,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case Just decl -> pure $ DO.UserObject (Src folded full) where - full = formatPretty (DeclPrinter.prettyDecl ppe r (PPE.typeName ppe r) decl) + full = formatPretty (DeclPrinter.prettyDecl pped r (PPE.typeName ppe r) decl) folded = formatPretty (DeclPrinter.prettyDeclHeader (PPE.typeName ppe r) decl) go :: (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)]) diff --git a/unison-src/transcripts/records.output.md b/unison-src/transcripts/records.output.md new file mode 100644 index 0000000000..cc9547a26a --- /dev/null +++ b/unison-src/transcripts/records.output.md @@ -0,0 +1,65 @@ +Ensure that Records keep their syntax after being added to the codebase + +## Record with 1 field + +```unison +unique type Record1 = { a : Text } +``` + +```ucm +.> view Record1 + + unique type Record1 = { a : Text } + +``` +## Record with 2 fields + +```unison +unique type Record2 = { a : Text, b : Int } +``` + +```ucm +.> view Record2 + + unique type Record2 = { a : Text, b : Int } + +``` +## Record with 3 fields + +```unison +unique type Record3 = { a : Text, b : Int, c : Nat } +``` + +```ucm +.> view Record3 + + unique type Record3 = { a : Text, b : Int, c : Nat } + +``` +## Record with many fields + +```unison +unique type Record4 = + { a : Text + , b : Int + , c : Nat + , d : Bytes + , e : Text + , f : Nat + , g : [Nat] + } +``` + +```ucm +.> view Record4 + + unique type Record4 + = { a : Text, + b : Int, + c : Nat, + d : Bytes, + e : Text, + f : Nat, + g : [Nat] } + +``` From 33934c2819e53710d250e02902b158a6c52719a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 17 Sep 2021 15:06:21 -0400 Subject: [PATCH 091/148] Update parser-typechecker/src/Unison/Lexer.hs Co-authored-by: Paul Chiusano --- parser-typechecker/src/Unison/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 5f1cf7cb76..98bd2e6ae2 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -916,7 +916,7 @@ lexemes' eof = P.optional space >> do Nothing -> err pos1 (UnexpectedDelimiter (quote close)) where quote s = "'" <> s <> "'" Just (block, n) -> do - S.put (env { layout = drop n (layout env), opening = Just block }) + S.put (env { layout = drop (n-1) (layout env) }) let opens = [Token (Reserved close) pos1 pos2] pure $ replicate (n-1) (Token Close pos1 pos2) ++ opens From 47ad9e54c5b45b51ea6f78d729c1630684342b6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 17 Sep 2021 15:06:35 -0400 Subject: [PATCH 092/148] Update parser-typechecker/src/Unison/Lexer.hs Co-authored-by: Paul Chiusano --- parser-typechecker/src/Unison/Lexer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 98bd2e6ae2..95bb22bd2b 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -917,8 +917,8 @@ lexemes' eof = P.optional space >> do where quote s = "'" <> s <> "'" Just (block, n) -> do S.put (env { layout = drop (n-1) (layout env) }) - let opens = [Token (Reserved close) pos1 pos2] - pure $ replicate (n-1) (Token Close pos1 pos2) ++ opens + let delims = [Token (Reserved close) pos1 pos2] + pure $ replicate (n-1) (Token Close pos1 pos2) ++ delims close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] close' reopenBlockname open closeP = do From 62b58465da83ebdd4fc9920b827011befe5222b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 17 Sep 2021 15:12:25 -0400 Subject: [PATCH 093/148] Minor edit to lexer --- parser-typechecker/src/Unison/Lexer.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 5f1cf7cb76..ee774f5ee5 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -875,10 +875,15 @@ lexemes' eof = P.optional space >> do matchWithBlocks = ["match-with", "cases"] parens = open "(" <|> close ["("] (lit ")") brackets = open "[" <|> close ["["] (lit "]") + -- `allowCommaToClose` determines if a comma should close inner blocks. + -- Currently there is a set of blocks where `,` is not treated specially + -- and it just emits a Reserved ",". There are currently only three: + -- `cases`, `match-with`, and `{` + allowCommaToClose match = not $ match `elem` ("{" : matchWithBlocks) commaSeparator = do env <- S.get case topBlockName (layout env) of - Just match | not (match `elem` matchWithBlocks || match == "{") -> + Just match | allowCommaToClose match -> blockDelimiter ["[", "("] (lit ",") _ -> fail "this comma is a pattern separator" From 4932490921991aa77a2d45757bc9b763f73d4493 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 17 Sep 2021 15:26:12 -0400 Subject: [PATCH 094/148] Fix warning --- parser-typechecker/src/Unison/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 122cada51f..cf6bc3b23d 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -920,7 +920,7 @@ lexemes' eof = P.optional space >> do case findClose open (layout env) of Nothing -> err pos1 (UnexpectedDelimiter (quote close)) where quote s = "'" <> s <> "'" - Just (block, n) -> do + Just (_, n) -> do S.put (env { layout = drop (n-1) (layout env) }) let delims = [Token (Reserved close) pos1 pos2] pure $ replicate (n-1) (Token Close pos1 pos2) ++ delims From 94c38e3ca6deccfabfff1894a14f12748ebf76c4 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sat, 18 Sep 2021 09:30:16 -0600 Subject: [PATCH 095/148] Fixed left-over code from test --- parser-typechecker/src/Unison/Builtin.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index fdf1fb83bf..d609a15b42 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -559,7 +559,8 @@ ioBuiltins = , ("IO.getBytes.impl.v3", handle --> nat --> iof bytes) , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) - , ("IO.systemTime.impl.v3", unit --> iof int) + , ("IO.systemTime.impl.v3", unit --> iof nat) + , ("IO.systemTime.impl.v4", unit --> iof int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) From bc3219008be52a1813ab4a9d6a7174c842aa8d83 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sat, 18 Sep 2021 14:58:49 -0600 Subject: [PATCH 096/148] Using a new name: systemTime2 --- parser-typechecker/src/Unison/Builtin.hs | 2 +- parser-typechecker/src/Unison/Runtime/Builtin.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index d609a15b42..2ac3de3c1b 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -560,7 +560,7 @@ ioBuiltins = , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) , ("IO.systemTime.impl.v3", unit --> iof nat) - , ("IO.systemTime.impl.v4", unit --> iof int) + , ("IO.systemTime2.impl.v1", unit --> iof int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index b802a0ce6f..64b74d8f4d 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1570,7 +1570,7 @@ declareForeigns = do declareForeign "IO.systemTime.impl.v3" unitToEFNat $ mkForeignIOF $ \() -> getPOSIXTime - declareForeign "IO.systemTime.impl.v4" unitToEFInt + declareForeign "IO.systemTime2.impl.v1" unitToEFInt $ mkForeignIOF $ \() -> fmap (1e6 *) getPOSIXTime declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox From 81535245eff60fb948b477aec779551e9696b509 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Sun, 19 Sep 2021 13:12:54 -0400 Subject: [PATCH 097/148] Remove trace from fieldnames The trace snug through to the merge. Remove it, and avoid random print statements when running UCM. --- parser-typechecker/src/Unison/DeclPrinter.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index 4f11fbba51..269f3d85d0 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -145,11 +145,11 @@ fieldNames env r name dd = case DD.constructors dd of fieldNames = Map.fromList [ (r, f) | (r, n) <- names , typename <- pure (HQ.toString name) - , typename `isPrefixOf` (traceShowId n) + , typename `isPrefixOf` n , rest <- pure $ drop (length typename + 1) n , (f, rest) <- pure $ span (/= '.') rest , rest `elem` ["",".set",".modify"] ] - in if traceShowId (Map.size fieldNames) == traceShowId (length names) then + in if Map.size fieldNames == length names then Just [ HQ.unsafeFromString name | v <- vars , Just (ref, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes] From 104d5925460b6c65981133fdb9e42cc715d98ff4 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sun, 19 Sep 2021 13:24:12 -0600 Subject: [PATCH 098/148] Fixed built-in IO ability to be reported as Ability on Server --- parser-typechecker/src/Unison/Server/Backend.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index a761b76e31..e2cb379948 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -308,6 +308,10 @@ termListEntry codebase b0 r n = do tag = if isDoc then Just Doc else if isTest then Just Test else Nothing pure $ TermEntry r n ot tag + +builtInIoAbility :: Reference +builtInIoAbility = Reference.unsafeFromText "##IO" + typeListEntry :: Monad m => Var v @@ -323,7 +327,8 @@ typeListEntry codebase r n = do pure $ case decl of Just (Left _) -> Ability _ -> Data - _ -> pure Data + -- IO is the only built-in ability + _ -> pure (if r == builtInIoAbility then Ability else Data) pure $ TypeEntry r n tag typeDeclHeader From be58064865dc23abf76bcf227a90564e0cdd9d44 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Mon, 20 Sep 2021 12:11:07 -0600 Subject: [PATCH 099/148] Removed new reference to built-in IO ability in favor of existing reference --- parser-typechecker/src/Unison/Server/Backend.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index e2cb379948..bb602b5000 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -308,10 +308,6 @@ termListEntry codebase b0 r n = do tag = if isDoc then Just Doc else if isTest then Just Test else Nothing pure $ TermEntry r n ot tag - -builtInIoAbility :: Reference -builtInIoAbility = Reference.unsafeFromText "##IO" - typeListEntry :: Monad m => Var v @@ -328,7 +324,7 @@ typeListEntry codebase r n = do Just (Left _) -> Ability _ -> Data -- IO is the only built-in ability - _ -> pure (if r == builtInIoAbility then Ability else Data) + _ -> pure (if r == Type.builtinIORef then Ability else Data) pure $ TypeEntry r n tag typeDeclHeader From 1c0d51caa3e0bc885d13066ee45bd9ac5abe6630 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Mon, 20 Sep 2021 13:59:59 -0600 Subject: [PATCH 100/148] Added STM to the list of built-in abilities reported by the server --- parser-typechecker/src/Unison/Server/Backend.hs | 2 +- unison-core/src/Unison/Type.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index bb602b5000..f02ac0a373 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -324,7 +324,7 @@ typeListEntry codebase r n = do Just (Left _) -> Ability _ -> Data -- IO is the only built-in ability - _ -> pure (if r == Type.builtinIORef then Ability else Data) + _ -> pure (if Set.member r Type.builtinAbilities then Ability else Data) pure $ TypeEntry r n tag typeDeclHeader diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index ce878fa82f..4eb9925e6c 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -688,6 +688,9 @@ hashComponents :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) hashComponents = ReferenceUtil.hashComponents $ refId () +builtinAbilities :: Set Reference +builtinAbilities = Set.fromList [builtinIORef, stmRef] + instance Hashable1 F where hash1 hashCycle hash e = let From abee4d14d3c0ff3330ced2f9118446c79fafeb2b Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Mon, 20 Sep 2021 14:24:57 -0600 Subject: [PATCH 101/148] Removed comment that was no longer relevant --- parser-typechecker/src/Unison/Server/Backend.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index f02ac0a373..f5face6693 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -323,7 +323,6 @@ typeListEntry codebase r n = do pure $ case decl of Just (Left _) -> Ability _ -> Data - -- IO is the only built-in ability _ -> pure (if Set.member r Type.builtinAbilities then Ability else Data) pure $ TypeEntry r n tag From a7d74e631fe86c2ad0b4d3332830e13639bb5af4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 20 Sep 2021 16:46:28 -0400 Subject: [PATCH 102/148] Code validation builtin for testing/debugging --- parser-typechecker/src/Unison/Builtin.hs | 1 + parser-typechecker/src/Unison/Runtime/ANF.hs | 1 + .../src/Unison/Runtime/Builtin.hs | 7 +++++ .../src/Unison/Runtime/MCode.hs | 2 ++ .../src/Unison/Runtime/Machine.hs | 30 ++++++++++++++++++- 5 files changed, 40 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 86aac71f5c..7add7e7ffe 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -633,6 +633,7 @@ codeBuiltins = , ("Code.serialize", code --> bytes) , ("Code.deserialize", bytes --> eithert text code) , ("Code.cache_", list (tuple [termLink,code]) --> io (list termLink)) + , ("Code.validate", list (tuple [termLink,code]) --> io unit) , ("Code.lookup", termLink --> io (optionalt code)) , ("Value.dependencies", value --> list termLink) , ("Value.serialize", value --> bytes) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 7a2db144ec..09fb839024 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -751,6 +751,7 @@ data POp | EQLU | CMPU | EROR -- Code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load + | CVLD -- validate | VALU | TLTT -- value, Term.Link.toText -- Debug | PRNT | INFO diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 9e5f016c36..512e74297d 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -738,6 +738,12 @@ code'lookup , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) ] +code'validate :: Var v => SuperNormal v +code'validate + = unop0 0 $ \[item] + -> TLets Direct [] [] (TPrm CVLD [item]) + $ TCon Ty.unitRef 0 [] + term'link'to'text :: Var v => SuperNormal v term'link'to'text = unop0 0 $ \[link] -> TPrm TLTT [link] @@ -1455,6 +1461,7 @@ builtinLookup , ("Code.isMissing", code'missing) , ("Code.cache_", code'cache) , ("Code.lookup", code'lookup) + , ("Code.validate", code'validate) , ("Value.load", value'load) , ("Value.value", value'create) , ("Link.Term.toText", term'link'to'text) diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs index 2e2000b781..2f90c32f15 100644 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ b/parser-typechecker/src/Unison/Runtime/MCode.hs @@ -330,6 +330,7 @@ data BPrim1 | FLTB -- flatten -- code | MISS | CACH | LKUP | LOAD -- isMissing,cache_,lookup,load + | CVLD -- validate | VALU | TLTT -- value, Term.Link.toText deriving (Show, Eq, Ord) @@ -1058,6 +1059,7 @@ emitPOp ANF.MISS = emitBP1 MISS emitPOp ANF.CACH = emitBP1 CACH emitPOp ANF.LKUP = emitBP1 LKUP emitPOp ANF.TLTT = emitBP1 TLTT +emitPOp ANF.CVLD = emitBP1 CVLD emitPOp ANF.LOAD = emitBP1 LOAD emitPOp ANF.VALU = emitBP1 VALU diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index dad14b488f..369df9800a 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -15,7 +15,7 @@ import GHC.Conc as STM (unsafeIOToSTM) import Data.Maybe (fromMaybe) import Data.Bits -import Data.Foldable (toList) +import Data.Foldable (toList, for_) import Data.Traversable import Data.Word (Word64) @@ -219,6 +219,12 @@ exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do pokeS bstk (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, ustk, bstk, k) +exec !env !denv !ustk !bstk !k (BPrim1 CVLD i) = do + arg <- peekOffS bstk i + news <- decodeCacheArgument arg + codeValidate news env + pure (denv, ustk, bstk, k) + exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do clink <- peekOff bstk i let Ref link = unwrapForeign $ marshalToForeign clink @@ -1187,6 +1193,7 @@ bprim1 !ustk !bstk FLTB i = do bprim1 !ustk !bstk MISS _ = pure (ustk, bstk) bprim1 !ustk !bstk CACH _ = pure (ustk, bstk) bprim1 !ustk !bstk LKUP _ = pure (ustk, bstk) +bprim1 !ustk !bstk CVLD _ = pure (ustk, bstk) bprim1 !ustk !bstk TLTT _ = pure (ustk, bstk) bprim1 !ustk !bstk LOAD _ = pure (ustk, bstk) bprim1 !ustk !bstk VALU _ = pure (ustk, bstk) @@ -1481,6 +1488,27 @@ addRefs vfrsh vfrom vto rs = do modifyTVar vto (nto <>) pure from +codeValidate + :: [(Reference, SuperGroup Symbol)] + -> CCache + -> IO () +codeValidate tml cc = do + rty0 <- readTVarIO (refTy cc) + fty <- readTVarIO (freshTy cc) + let f b r | b, M.notMember r rty0 = S.singleton r + | otherwise = mempty + ntys0 = (foldMap.foldMap) (groupLinks f) tml + ntys = M.fromList $ zip (S.toList ntys0) [fty..] + rty = ntys <> rty0 + ftm <- readTVarIO (freshTm cc) + rtm0 <- readTVarIO (refTm cc) + let (rs, gs) = unzip tml + rtm = rtm0 `M.withoutKeys` S.fromList rs + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) + combinate n g = emitCombs rns n g + for_ (zip [ftm..] gs) $ \(n, g) -> + evaluate $ combinate n g + cacheAdd0 :: S.Set Reference -> [(Reference, SuperGroup Symbol)] From 6f7db762c33c950549674e969cd328257ea14f4c Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 21 Sep 2021 12:36:00 -0400 Subject: [PATCH 103/148] Add a builtin for displaying `Code` --- parser-typechecker/src/Unison/Builtin.hs | 1 + parser-typechecker/src/Unison/Runtime/Builtin.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 7add7e7ffe..d0f905f6b8 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -635,6 +635,7 @@ codeBuiltins = , ("Code.cache_", list (tuple [termLink,code]) --> io (list termLink)) , ("Code.validate", list (tuple [termLink,code]) --> io unit) , ("Code.lookup", termLink --> io (optionalt code)) + , ("Code.display", text --> code --> text) , ("Value.dependencies", value --> list termLink) , ("Value.serialize", value --> bytes) , ("Value.deserialize", bytes --> eithert text value) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 512e74297d..94649a33cd 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1800,6 +1800,8 @@ declareForeigns = do -> pure . Bytes.fromArray $ serializeGroup sg declareForeign "Code.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeGroup @Symbol . Bytes.toArray + declareForeign "Code.display" boxBoxDirect . mkForeign + $ \(nm,sg) -> pure $ prettyGroup @Symbol (Text.unpack nm) sg "" declareForeign "Value.dependencies" boxDirect . mkForeign $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks From f907702d6695f53a037535c7ab860219d59d9a42 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 21 Sep 2021 12:43:32 -0400 Subject: [PATCH 104/148] Missed abstracting pattern variables in `Code` deserialization --- parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index 38864fe5bd..189cce769c 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -528,7 +528,7 @@ getCase ctx frsh0 = do let l = length ccs frsh = frsh0 + fromIntegral l us = getFresh <$> take l [frsh0..] - (,) ccs <$> getNormal (us++ctx) frsh + (,) ccs . TAbss us <$> getNormal (us++ctx) frsh putCTag :: MonadPut m => CTag -> m () putCTag c = serialize (VarInt $ fromEnum c) From 9471ad50cd51a1c6779e76355d0814b0589b7fda Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 21 Sep 2021 16:16:26 -0400 Subject: [PATCH 105/148] Tweak `Code.validate` - Expose the internal compiler bugs as a Failure in unison --- parser-typechecker/src/Unison/Builtin.hs | 2 +- .../src/Unison/Runtime/Builtin.hs | 14 ++++++-- .../src/Unison/Runtime/Machine.hs | 33 ++++++++++++++----- 3 files changed, 36 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index d0f905f6b8..84d0d55bc1 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -633,7 +633,7 @@ codeBuiltins = , ("Code.serialize", code --> bytes) , ("Code.deserialize", bytes --> eithert text code) , ("Code.cache_", list (tuple [termLink,code]) --> io (list termLink)) - , ("Code.validate", list (tuple [termLink,code]) --> io unit) + , ("Code.validate", list (tuple [termLink,code]) --> io (optionalt failure)) , ("Code.lookup", termLink --> io (optionalt code)) , ("Code.display", text --> code --> text) , ("Value.dependencies", value --> list termLink) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 94649a33cd..4ea1067788 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -740,9 +740,17 @@ code'lookup code'validate :: Var v => SuperNormal v code'validate - = unop0 0 $ \[item] - -> TLets Direct [] [] (TPrm CVLD [item]) - $ TCon Ty.unitRef 0 [] + = unop0 5 $ \[item, t, ref, msg, extra, fail] + -> TLetD t UN (TPrm CVLD [item]) + . TMatch t . MatchSum + $ mapFromList + [ (1, ([BX, BX, BX],) + . TAbss [ref, msg, extra] + . TLetD fail BX (TCon Ty.failureRef 0 [ref, msg, extra]) + $ TCon Ty.optionalRef 1 [fail]) + , (0, ([],) + $ TCon Ty.optionalRef 0 []) + ] term'link'to'text :: Var v => SuperNormal v term'link'to'text diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 369df9800a..caf35fcd15 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -15,7 +15,7 @@ import GHC.Conc as STM (unsafeIOToSTM) import Data.Maybe (fromMaybe) import Data.Bits -import Data.Foldable (toList, for_) +import Data.Foldable (toList, traverse_) import Data.Traversable import Data.Word (Word64) @@ -33,14 +33,14 @@ import qualified Data.Primitive.PrimArray as PA import Text.Read (readMaybe) -import Unison.Builtin.Decls (exceptionRef) +import Unison.Builtin.Decls (exceptionRef, ioFailureRef) import Unison.Reference (Reference(Builtin), toShortHash) import Unison.Referent (pattern Ref) import qualified Unison.ShortHash as SH import Unison.Symbol (Symbol) import Unison.Runtime.ANF - as ANF (Mem(..), SuperGroup, valueLinks, groupLinks) + as ANF (Mem(..), CompileExn(..), SuperGroup, valueLinks, groupLinks) import qualified Unison.Runtime.ANF as ANF import Unison.Runtime.Builtin import Unison.Runtime.Exception @@ -52,6 +52,7 @@ import Unison.Runtime.MCode import qualified Unison.Type as Rf import qualified Unison.Util.Bytes as By +import Unison.Util.Pretty (toPlainUnbroken) import Unison.Util.EnumContainers as EC type Tag = Word64 @@ -222,8 +223,19 @@ exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do exec !env !denv !ustk !bstk !k (BPrim1 CVLD i) = do arg <- peekOffS bstk i news <- decodeCacheArgument arg - codeValidate news env - pure (denv, ustk, bstk, k) + codeValidate news env >>= \case + Nothing -> do + ustk <- bump ustk + poke ustk 0 + pure (denv, ustk, bstk, k) + Just (Failure ref msg clo) -> do + ustk <- bump ustk + bstk <- bumpn bstk 3 + poke ustk 1 + poke bstk (Foreign $ Wrap Rf.typeLinkRef ref) + pokeOffBi bstk 1 msg + pokeOff bstk 2 clo + pure (denv, ustk, bstk, k) exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do clink <- peekOff bstk i @@ -1491,7 +1503,7 @@ addRefs vfrsh vfrom vto rs = do codeValidate :: [(Reference, SuperGroup Symbol)] -> CCache - -> IO () + -> IO (Maybe (Failure Closure)) codeValidate tml cc = do rty0 <- readTVarIO (refTy cc) fty <- readTVarIO (freshTy cc) @@ -1505,9 +1517,12 @@ codeValidate tml cc = do let (rs, gs) = unzip tml rtm = rtm0 `M.withoutKeys` S.fromList rs rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) - combinate n g = emitCombs rns n g - for_ (zip [ftm..] gs) $ \(n, g) -> - evaluate $ combinate n g + combinate (n, g) = evaluate $ emitCombs rns n g + (Nothing <$ traverse_ combinate (zip [ftm..] gs)) + `catch` \(CE cs perr) -> let + msg = Tx.pack $ toPlainUnbroken perr + extra = Foreign . Wrap Rf.textRef . Tx.pack $ show cs in + pure . Just $ Failure ioFailureRef msg extra cacheAdd0 :: S.Set Reference From bcdb0d551b536a63367f59e8fdc2d8d3e149ca0f Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 21 Sep 2021 17:46:00 -0400 Subject: [PATCH 106/148] Transcript updates - Added some codeops tests using the new validate - Updated other transcript output for new builtins --- unison-src/transcripts-using-base/codeops.md | 31 + .../transcripts-using-base/codeops.output.md | 64 ++ unison-src/transcripts/alias-many.output.md | 698 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 8 files changed, 469 insertions(+), 372 deletions(-) diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 94db31d190..0f7841764a 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -166,3 +166,34 @@ to actual show that the serialization works. .> io.test tests .> io.test badLoad ``` + +```unison +validateTest : Link.Term ->{IO} Result +validateTest l = match Code.lookup l with + None -> Fail "Couldn't look up link" + Some co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code pre" + None -> match Code.deserialize (Code.serialize co) with + Left _ -> Fail "code failed deserialization" + Right co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code post" + None -> Ok "validated" + +vtests : '{IO} [Result] +vtests _ = + List.map validateTest + [ termLink fib10 + , termLink compose + , termLink List.all + , termLink hex + , termLink isDirectory + , termLink delay + , termLink printLine + , termLink isNone + ] +``` + +```ucm +.> add +.> io.test vtests +``` diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index eb8d902d4a..8f8b2477f2 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -281,3 +281,67 @@ to actual show that the serialization works. Tip: Use view badLoad to view the source of a test. ``` +```unison +validateTest : Link.Term ->{IO} Result +validateTest l = match Code.lookup l with + None -> Fail "Couldn't look up link" + Some co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code pre" + None -> match Code.deserialize (Code.serialize co) with + Left _ -> Fail "code failed deserialization" + Right co -> match Code.validate [(l, co)] with + Some f -> Fail "invalid code post" + None -> Ok "validated" + +vtests : '{IO} [Result] +vtests _ = + List.map validateTest + [ termLink fib10 + , termLink compose + , termLink List.all + , termLink hex + , termLink isDirectory + , termLink delay + , termLink printLine + , termLink isNone + ] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + validateTest : Link.Term ->{IO} Result + vtests : '{IO} [Result] + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + validateTest : Link.Term ->{IO} Result + vtests : '{IO} [Result] + +.> io.test vtests + + New test results: + + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + ◉ vtests validated + + ✅ 8 test(s) passing + + Tip: Use view vtests to view the source of a test. + +``` diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index ec7f83540e..25e281533c 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -61,402 +61,404 @@ Let's try it! 41. Code.cache_ : [(Term, Code)] ->{IO} [Term] 42. Code.dependencies : Code -> [Term] 43. Code.deserialize : Bytes -> Either Text Code - 44. Code.isMissing : Term ->{IO} Boolean - 45. Code.lookup : Term ->{IO} Optional Code - 46. Code.serialize : Code -> Bytes - 47. crypto.hash : HashAlgorithm -> a -> Bytes - 48. builtin type crypto.HashAlgorithm - 49. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 50. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 51. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 52. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 56. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 57. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 58. crypto.hmacBytes : HashAlgorithm + 44. Code.display : Text -> Code -> Text + 45. Code.isMissing : Term ->{IO} Boolean + 46. Code.lookup : Term ->{IO} Optional Code + 47. Code.serialize : Code -> Bytes + 48. Code.validate : [(Term, Code)] ->{IO} Optional Failure + 49. crypto.hash : HashAlgorithm -> a -> Bytes + 50. builtin type crypto.HashAlgorithm + 51. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 52. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 53. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 54. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 55. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 56. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 57. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 58. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 59. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 60. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 59. Debug.watch : Text -> a -> a - 60. unique type Doc - 61. Doc.Blob : Text -> Doc - 62. Doc.Evaluate : Term -> Doc - 63. Doc.Join : [Doc] -> Doc - 64. Doc.Link : Link -> Doc - 65. Doc.Signature : Term -> Doc - 66. Doc.Source : Link -> Doc - 67. structural type Either a b - 68. Either.Left : a -> Either a b - 69. Either.Right : b -> Either a b - 70. structural ability Exception - 71. Exception.raise : Failure ->{Exception} x - 72. builtin type Float - 73. Float.* : Float -> Float -> Float - 74. Float.+ : Float -> Float -> Float - 75. Float.- : Float -> Float -> Float - 76. Float./ : Float -> Float -> Float - 77. Float.abs : Float -> Float - 78. Float.acos : Float -> Float - 79. Float.acosh : Float -> Float - 80. Float.asin : Float -> Float - 81. Float.asinh : Float -> Float - 82. Float.atan : Float -> Float - 83. Float.atan2 : Float -> Float -> Float - 84. Float.atanh : Float -> Float - 85. Float.ceiling : Float -> Int - 86. Float.cos : Float -> Float - 87. Float.cosh : Float -> Float - 88. Float.eq : Float -> Float -> Boolean - 89. Float.exp : Float -> Float - 90. Float.floor : Float -> Int - 91. Float.fromRepresentation : Nat -> Float - 92. Float.fromText : Text -> Optional Float - 93. Float.gt : Float -> Float -> Boolean - 94. Float.gteq : Float -> Float -> Boolean - 95. Float.log : Float -> Float - 96. Float.logBase : Float -> Float -> Float - 97. Float.lt : Float -> Float -> Boolean - 98. Float.lteq : Float -> Float -> Boolean - 99. Float.max : Float -> Float -> Float - 100. Float.min : Float -> Float -> Float - 101. Float.pow : Float -> Float -> Float - 102. Float.round : Float -> Int - 103. Float.sin : Float -> Float - 104. Float.sinh : Float -> Float - 105. Float.sqrt : Float -> Float - 106. Float.tan : Float -> Float - 107. Float.tanh : Float -> Float - 108. Float.toRepresentation : Float -> Nat - 109. Float.toText : Float -> Text - 110. Float.truncate : Float -> Int - 111. builtin type Int - 112. Int.* : Int -> Int -> Int - 113. Int.+ : Int -> Int -> Int - 114. Int.- : Int -> Int -> Int - 115. Int./ : Int -> Int -> Int - 116. Int.and : Int -> Int -> Int - 117. Int.complement : Int -> Int - 118. Int.eq : Int -> Int -> Boolean - 119. Int.fromRepresentation : Nat -> Int - 120. Int.fromText : Text -> Optional Int - 121. Int.gt : Int -> Int -> Boolean - 122. Int.gteq : Int -> Int -> Boolean - 123. Int.increment : Int -> Int - 124. Int.isEven : Int -> Boolean - 125. Int.isOdd : Int -> Boolean - 126. Int.leadingZeros : Int -> Nat - 127. Int.lt : Int -> Int -> Boolean - 128. Int.lteq : Int -> Int -> Boolean - 129. Int.mod : Int -> Int -> Int - 130. Int.negate : Int -> Int - 131. Int.or : Int -> Int -> Int - 132. Int.popCount : Int -> Nat - 133. Int.pow : Int -> Nat -> Int - 134. Int.shiftLeft : Int -> Nat -> Int - 135. Int.shiftRight : Int -> Nat -> Int - 136. Int.signum : Int -> Int - 137. Int.toFloat : Int -> Float - 138. Int.toRepresentation : Int -> Nat - 139. Int.toText : Int -> Text - 140. Int.trailingZeros : Int -> Nat - 141. Int.truncate0 : Int -> Nat - 142. Int.xor : Int -> Int -> Int - 143. unique type io2.BufferMode - 144. io2.BufferMode.BlockBuffering : BufferMode - 145. io2.BufferMode.LineBuffering : BufferMode - 146. io2.BufferMode.NoBuffering : BufferMode - 147. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 148. unique type io2.Failure - 149. io2.Failure.Failure : Type -> Text -> Any -> Failure - 150. unique type io2.FileMode - 151. io2.FileMode.Append : FileMode - 152. io2.FileMode.Read : FileMode - 153. io2.FileMode.ReadWrite : FileMode - 154. io2.FileMode.Write : FileMode - 155. builtin type io2.Handle - 156. builtin type io2.IO - 157. io2.IO.clientSocket.impl : Text + 61. Debug.watch : Text -> a -> a + 62. unique type Doc + 63. Doc.Blob : Text -> Doc + 64. Doc.Evaluate : Term -> Doc + 65. Doc.Join : [Doc] -> Doc + 66. Doc.Link : Link -> Doc + 67. Doc.Signature : Term -> Doc + 68. Doc.Source : Link -> Doc + 69. structural type Either a b + 70. Either.Left : a -> Either a b + 71. Either.Right : b -> Either a b + 72. structural ability Exception + 73. Exception.raise : Failure ->{Exception} x + 74. builtin type Float + 75. Float.* : Float -> Float -> Float + 76. Float.+ : Float -> Float -> Float + 77. Float.- : Float -> Float -> Float + 78. Float./ : Float -> Float -> Float + 79. Float.abs : Float -> Float + 80. Float.acos : Float -> Float + 81. Float.acosh : Float -> Float + 82. Float.asin : Float -> Float + 83. Float.asinh : Float -> Float + 84. Float.atan : Float -> Float + 85. Float.atan2 : Float -> Float -> Float + 86. Float.atanh : Float -> Float + 87. Float.ceiling : Float -> Int + 88. Float.cos : Float -> Float + 89. Float.cosh : Float -> Float + 90. Float.eq : Float -> Float -> Boolean + 91. Float.exp : Float -> Float + 92. Float.floor : Float -> Int + 93. Float.fromRepresentation : Nat -> Float + 94. Float.fromText : Text -> Optional Float + 95. Float.gt : Float -> Float -> Boolean + 96. Float.gteq : Float -> Float -> Boolean + 97. Float.log : Float -> Float + 98. Float.logBase : Float -> Float -> Float + 99. Float.lt : Float -> Float -> Boolean + 100. Float.lteq : Float -> Float -> Boolean + 101. Float.max : Float -> Float -> Float + 102. Float.min : Float -> Float -> Float + 103. Float.pow : Float -> Float -> Float + 104. Float.round : Float -> Int + 105. Float.sin : Float -> Float + 106. Float.sinh : Float -> Float + 107. Float.sqrt : Float -> Float + 108. Float.tan : Float -> Float + 109. Float.tanh : Float -> Float + 110. Float.toRepresentation : Float -> Nat + 111. Float.toText : Float -> Text + 112. Float.truncate : Float -> Int + 113. builtin type Int + 114. Int.* : Int -> Int -> Int + 115. Int.+ : Int -> Int -> Int + 116. Int.- : Int -> Int -> Int + 117. Int./ : Int -> Int -> Int + 118. Int.and : Int -> Int -> Int + 119. Int.complement : Int -> Int + 120. Int.eq : Int -> Int -> Boolean + 121. Int.fromRepresentation : Nat -> Int + 122. Int.fromText : Text -> Optional Int + 123. Int.gt : Int -> Int -> Boolean + 124. Int.gteq : Int -> Int -> Boolean + 125. Int.increment : Int -> Int + 126. Int.isEven : Int -> Boolean + 127. Int.isOdd : Int -> Boolean + 128. Int.leadingZeros : Int -> Nat + 129. Int.lt : Int -> Int -> Boolean + 130. Int.lteq : Int -> Int -> Boolean + 131. Int.mod : Int -> Int -> Int + 132. Int.negate : Int -> Int + 133. Int.or : Int -> Int -> Int + 134. Int.popCount : Int -> Nat + 135. Int.pow : Int -> Nat -> Int + 136. Int.shiftLeft : Int -> Nat -> Int + 137. Int.shiftRight : Int -> Nat -> Int + 138. Int.signum : Int -> Int + 139. Int.toFloat : Int -> Float + 140. Int.toRepresentation : Int -> Nat + 141. Int.toText : Int -> Text + 142. Int.trailingZeros : Int -> Nat + 143. Int.truncate0 : Int -> Nat + 144. Int.xor : Int -> Int -> Int + 145. unique type io2.BufferMode + 146. io2.BufferMode.BlockBuffering : BufferMode + 147. io2.BufferMode.LineBuffering : BufferMode + 148. io2.BufferMode.NoBuffering : BufferMode + 149. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 150. unique type io2.Failure + 151. io2.Failure.Failure : Type -> Text -> Any -> Failure + 152. unique type io2.FileMode + 153. io2.FileMode.Append : FileMode + 154. io2.FileMode.Read : FileMode + 155. io2.FileMode.ReadWrite : FileMode + 156. io2.FileMode.Write : FileMode + 157. builtin type io2.Handle + 158. builtin type io2.IO + 159. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 158. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 159. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 160. io2.IO.createDirectory.impl : Text + 160. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 161. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 162. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 161. io2.IO.createTempDirectory.impl : Text + 163. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 162. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 163. io2.IO.directoryContents.impl : Text + 164. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 165. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 164. io2.IO.fileExists.impl : Text + 166. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 165. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 166. io2.IO.getBuffering.impl : Handle + 167. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 168. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 167. io2.IO.getBytes.impl : Handle + 169. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 168. io2.IO.getCurrentDirectory.impl : '{IO} Either + 170. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 169. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 170. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 171. io2.IO.getFileTimestamp.impl : Text + 171. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 172. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 173. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 172. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 173. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 174. io2.IO.handlePosition.impl : Handle + 174. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 175. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 176. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 175. io2.IO.isDirectory.impl : Text + 177. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 176. io2.IO.isFileEOF.impl : Handle + 178. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 177. io2.IO.isFileOpen.impl : Handle + 179. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 178. io2.IO.isSeekable.impl : Handle + 180. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 179. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 180. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 181. io2.IO.openFile.impl : Text + 181. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 182. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 183. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 182. io2.IO.putBytes.impl : Handle + 184. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 183. io2.IO.ref : a ->{IO} Ref {IO} a - 184. io2.IO.removeDirectory.impl : Text + 185. io2.IO.ref : a ->{IO} Ref {IO} a + 186. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 185. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 186. io2.IO.renameDirectory.impl : Text + 187. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 188. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 187. io2.IO.renameFile.impl : Text + 189. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 188. io2.IO.seekHandle.impl : Handle + 190. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 189. io2.IO.serverSocket.impl : Optional Text + 191. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 190. io2.IO.setBuffering.impl : Handle + 192. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 191. io2.IO.setCurrentDirectory.impl : Text + 193. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 192. io2.IO.socketAccept.impl : Socket + 194. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 193. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 194. io2.IO.socketReceive.impl : Socket + 195. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 196. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 195. io2.IO.socketSend.impl : Socket + 197. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 196. io2.IO.stdHandle : StdHandle -> Handle - 197. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 198. unique type io2.IOError - 199. io2.IOError.AlreadyExists : IOError - 200. io2.IOError.EOF : IOError - 201. io2.IOError.IllegalOperation : IOError - 202. io2.IOError.NoSuchThing : IOError - 203. io2.IOError.PermissionDenied : IOError - 204. io2.IOError.ResourceBusy : IOError - 205. io2.IOError.ResourceExhausted : IOError - 206. io2.IOError.UserError : IOError - 207. unique type io2.IOFailure - 208. builtin type io2.MVar - 209. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 210. io2.MVar.new : a ->{IO} MVar a - 211. io2.MVar.newEmpty : '{IO} MVar a - 212. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 213. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 214. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 215. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 216. io2.MVar.tryPut.impl : MVar a + 198. io2.IO.stdHandle : StdHandle -> Handle + 199. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 200. unique type io2.IOError + 201. io2.IOError.AlreadyExists : IOError + 202. io2.IOError.EOF : IOError + 203. io2.IOError.IllegalOperation : IOError + 204. io2.IOError.NoSuchThing : IOError + 205. io2.IOError.PermissionDenied : IOError + 206. io2.IOError.ResourceBusy : IOError + 207. io2.IOError.ResourceExhausted : IOError + 208. io2.IOError.UserError : IOError + 209. unique type io2.IOFailure + 210. builtin type io2.MVar + 211. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 212. io2.MVar.new : a ->{IO} MVar a + 213. io2.MVar.newEmpty : '{IO} MVar a + 214. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 215. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 216. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 217. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 218. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 217. io2.MVar.tryRead.impl : MVar a + 219. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 218. io2.MVar.tryTake : MVar a ->{IO} Optional a - 219. unique type io2.SeekMode - 220. io2.SeekMode.AbsoluteSeek : SeekMode - 221. io2.SeekMode.RelativeSeek : SeekMode - 222. io2.SeekMode.SeekFromEnd : SeekMode - 223. builtin type io2.Socket - 224. unique type io2.StdHandle - 225. io2.StdHandle.StdErr : StdHandle - 226. io2.StdHandle.StdIn : StdHandle - 227. io2.StdHandle.StdOut : StdHandle - 228. builtin type io2.STM - 229. io2.STM.atomically : '{STM} a ->{IO} a - 230. io2.STM.retry : '{STM} a - 231. builtin type io2.ThreadId - 232. builtin type io2.Tls - 233. builtin type io2.Tls.Cipher - 234. builtin type io2.Tls.ClientConfig - 235. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 220. io2.MVar.tryTake : MVar a ->{IO} Optional a + 221. unique type io2.SeekMode + 222. io2.SeekMode.AbsoluteSeek : SeekMode + 223. io2.SeekMode.RelativeSeek : SeekMode + 224. io2.SeekMode.SeekFromEnd : SeekMode + 225. builtin type io2.Socket + 226. unique type io2.StdHandle + 227. io2.StdHandle.StdErr : StdHandle + 228. io2.StdHandle.StdIn : StdHandle + 229. io2.StdHandle.StdOut : StdHandle + 230. builtin type io2.STM + 231. io2.STM.atomically : '{STM} a ->{IO} a + 232. io2.STM.retry : '{STM} a + 233. builtin type io2.ThreadId + 234. builtin type io2.Tls + 235. builtin type io2.Tls.Cipher + 236. builtin type io2.Tls.ClientConfig + 237. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 236. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 238. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 237. io2.Tls.ClientConfig.default : Text + 239. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 238. io2.Tls.ClientConfig.versions.set : [Version] + 240. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 239. io2.Tls.decodeCert.impl : Bytes + 241. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 240. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 241. io2.Tls.encodeCert : SignedCert -> Bytes - 242. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 243. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 244. io2.Tls.newClient.impl : ClientConfig + 242. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 243. io2.Tls.encodeCert : SignedCert -> Bytes + 244. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 245. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 246. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 245. io2.Tls.newServer.impl : ServerConfig + 247. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 246. builtin type io2.Tls.PrivateKey - 247. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 248. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 249. builtin type io2.Tls.ServerConfig - 250. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 248. builtin type io2.Tls.PrivateKey + 249. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 250. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 251. builtin type io2.Tls.ServerConfig + 252. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 251. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 253. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 252. io2.Tls.ServerConfig.default : [SignedCert] + 254. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 253. io2.Tls.ServerConfig.versions.set : [Version] + 255. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 254. builtin type io2.Tls.SignedCert - 255. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 256. builtin type io2.Tls.Version - 257. unique type io2.TlsFailure - 258. builtin type io2.TVar - 259. io2.TVar.new : a ->{STM} TVar a - 260. io2.TVar.newIO : a ->{IO} TVar a - 261. io2.TVar.read : TVar a ->{STM} a - 262. io2.TVar.readIO : TVar a ->{IO} a - 263. io2.TVar.swap : TVar a -> a ->{STM} a - 264. io2.TVar.write : TVar a -> a ->{STM} () - 265. unique type IsPropagated - 266. IsPropagated.IsPropagated : IsPropagated - 267. unique type IsTest - 268. IsTest.IsTest : IsTest - 269. unique type Link - 270. builtin type Link.Term - 271. Link.Term : Term -> Link - 272. Link.Term.toText : Term -> Text - 273. builtin type Link.Type - 274. Link.Type : Type -> Link - 275. builtin type List - 276. List.++ : [a] -> [a] -> [a] - 277. List.+: : a -> [a] -> [a] - 278. List.:+ : [a] -> a -> [a] - 279. List.at : Nat -> [a] -> Optional a - 280. List.cons : a -> [a] -> [a] - 281. List.drop : Nat -> [a] -> [a] - 282. List.empty : [a] - 283. List.size : [a] -> Nat - 284. List.snoc : [a] -> a -> [a] - 285. List.take : Nat -> [a] -> [a] - 286. metadata.isPropagated : IsPropagated - 287. metadata.isTest : IsTest - 288. builtin type Nat - 289. Nat.* : Nat -> Nat -> Nat - 290. Nat.+ : Nat -> Nat -> Nat - 291. Nat./ : Nat -> Nat -> Nat - 292. Nat.and : Nat -> Nat -> Nat - 293. Nat.complement : Nat -> Nat - 294. Nat.drop : Nat -> Nat -> Nat - 295. Nat.eq : Nat -> Nat -> Boolean - 296. Nat.fromText : Text -> Optional Nat - 297. Nat.gt : Nat -> Nat -> Boolean - 298. Nat.gteq : Nat -> Nat -> Boolean - 299. Nat.increment : Nat -> Nat - 300. Nat.isEven : Nat -> Boolean - 301. Nat.isOdd : Nat -> Boolean - 302. Nat.leadingZeros : Nat -> Nat - 303. Nat.lt : Nat -> Nat -> Boolean - 304. Nat.lteq : Nat -> Nat -> Boolean - 305. Nat.mod : Nat -> Nat -> Nat - 306. Nat.or : Nat -> Nat -> Nat - 307. Nat.popCount : Nat -> Nat - 308. Nat.pow : Nat -> Nat -> Nat - 309. Nat.shiftLeft : Nat -> Nat -> Nat - 310. Nat.shiftRight : Nat -> Nat -> Nat - 311. Nat.sub : Nat -> Nat -> Int - 312. Nat.toFloat : Nat -> Float - 313. Nat.toInt : Nat -> Int - 314. Nat.toText : Nat -> Text - 315. Nat.trailingZeros : Nat -> Nat - 316. Nat.xor : Nat -> Nat -> Nat - 317. structural type Optional a - 318. Optional.None : Optional a - 319. Optional.Some : a -> Optional a - 320. builtin type Ref - 321. Ref.read : Ref g a ->{g} a - 322. Ref.write : Ref g a -> a ->{g} () - 323. builtin type Request - 324. builtin type Scope - 325. Scope.ref : a ->{Scope s} Ref {Scope s} a - 326. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 327. structural type SeqView a b - 328. SeqView.VElem : a -> b -> SeqView a b - 329. SeqView.VEmpty : SeqView a b - 330. unique type Test.Result - 331. Test.Result.Fail : Text -> Result - 332. Test.Result.Ok : Text -> Result - 333. builtin type Text - 334. Text.!= : Text -> Text -> Boolean - 335. Text.++ : Text -> Text -> Text - 336. Text.drop : Nat -> Text -> Text - 337. Text.empty : Text - 338. Text.eq : Text -> Text -> Boolean - 339. Text.fromCharList : [Char] -> Text - 340. Text.fromUtf8.impl : Bytes -> Either Failure Text - 341. Text.gt : Text -> Text -> Boolean - 342. Text.gteq : Text -> Text -> Boolean - 343. Text.lt : Text -> Text -> Boolean - 344. Text.lteq : Text -> Text -> Boolean - 345. Text.repeat : Nat -> Text -> Text - 346. Text.size : Text -> Nat - 347. Text.take : Nat -> Text -> Text - 348. Text.toCharList : Text -> [Char] - 349. Text.toUtf8 : Text -> Bytes - 350. Text.uncons : Text -> Optional (Char, Text) - 351. Text.unsnoc : Text -> Optional (Text, Char) - 352. todo : a -> b - 353. structural type Tuple a b - 354. Tuple.Cons : a -> b -> Tuple a b - 355. structural type Unit - 356. Unit.Unit : () - 357. Universal.< : a -> a -> Boolean - 358. Universal.<= : a -> a -> Boolean - 359. Universal.== : a -> a -> Boolean - 360. Universal.> : a -> a -> Boolean - 361. Universal.>= : a -> a -> Boolean - 362. Universal.compare : a -> a -> Int - 363. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 364. builtin type Value - 365. Value.dependencies : Value -> [Term] - 366. Value.deserialize : Bytes -> Either Text Value - 367. Value.load : Value ->{IO} Either [Term] a - 368. Value.serialize : Value -> Bytes - 369. Value.value : a -> Value + 256. builtin type io2.Tls.SignedCert + 257. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 258. builtin type io2.Tls.Version + 259. unique type io2.TlsFailure + 260. builtin type io2.TVar + 261. io2.TVar.new : a ->{STM} TVar a + 262. io2.TVar.newIO : a ->{IO} TVar a + 263. io2.TVar.read : TVar a ->{STM} a + 264. io2.TVar.readIO : TVar a ->{IO} a + 265. io2.TVar.swap : TVar a -> a ->{STM} a + 266. io2.TVar.write : TVar a -> a ->{STM} () + 267. unique type IsPropagated + 268. IsPropagated.IsPropagated : IsPropagated + 269. unique type IsTest + 270. IsTest.IsTest : IsTest + 271. unique type Link + 272. builtin type Link.Term + 273. Link.Term : Term -> Link + 274. Link.Term.toText : Term -> Text + 275. builtin type Link.Type + 276. Link.Type : Type -> Link + 277. builtin type List + 278. List.++ : [a] -> [a] -> [a] + 279. List.+: : a -> [a] -> [a] + 280. List.:+ : [a] -> a -> [a] + 281. List.at : Nat -> [a] -> Optional a + 282. List.cons : a -> [a] -> [a] + 283. List.drop : Nat -> [a] -> [a] + 284. List.empty : [a] + 285. List.size : [a] -> Nat + 286. List.snoc : [a] -> a -> [a] + 287. List.take : Nat -> [a] -> [a] + 288. metadata.isPropagated : IsPropagated + 289. metadata.isTest : IsTest + 290. builtin type Nat + 291. Nat.* : Nat -> Nat -> Nat + 292. Nat.+ : Nat -> Nat -> Nat + 293. Nat./ : Nat -> Nat -> Nat + 294. Nat.and : Nat -> Nat -> Nat + 295. Nat.complement : Nat -> Nat + 296. Nat.drop : Nat -> Nat -> Nat + 297. Nat.eq : Nat -> Nat -> Boolean + 298. Nat.fromText : Text -> Optional Nat + 299. Nat.gt : Nat -> Nat -> Boolean + 300. Nat.gteq : Nat -> Nat -> Boolean + 301. Nat.increment : Nat -> Nat + 302. Nat.isEven : Nat -> Boolean + 303. Nat.isOdd : Nat -> Boolean + 304. Nat.leadingZeros : Nat -> Nat + 305. Nat.lt : Nat -> Nat -> Boolean + 306. Nat.lteq : Nat -> Nat -> Boolean + 307. Nat.mod : Nat -> Nat -> Nat + 308. Nat.or : Nat -> Nat -> Nat + 309. Nat.popCount : Nat -> Nat + 310. Nat.pow : Nat -> Nat -> Nat + 311. Nat.shiftLeft : Nat -> Nat -> Nat + 312. Nat.shiftRight : Nat -> Nat -> Nat + 313. Nat.sub : Nat -> Nat -> Int + 314. Nat.toFloat : Nat -> Float + 315. Nat.toInt : Nat -> Int + 316. Nat.toText : Nat -> Text + 317. Nat.trailingZeros : Nat -> Nat + 318. Nat.xor : Nat -> Nat -> Nat + 319. structural type Optional a + 320. Optional.None : Optional a + 321. Optional.Some : a -> Optional a + 322. builtin type Ref + 323. Ref.read : Ref g a ->{g} a + 324. Ref.write : Ref g a -> a ->{g} () + 325. builtin type Request + 326. builtin type Scope + 327. Scope.ref : a ->{Scope s} Ref {Scope s} a + 328. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 329. structural type SeqView a b + 330. SeqView.VElem : a -> b -> SeqView a b + 331. SeqView.VEmpty : SeqView a b + 332. unique type Test.Result + 333. Test.Result.Fail : Text -> Result + 334. Test.Result.Ok : Text -> Result + 335. builtin type Text + 336. Text.!= : Text -> Text -> Boolean + 337. Text.++ : Text -> Text -> Text + 338. Text.drop : Nat -> Text -> Text + 339. Text.empty : Text + 340. Text.eq : Text -> Text -> Boolean + 341. Text.fromCharList : [Char] -> Text + 342. Text.fromUtf8.impl : Bytes -> Either Failure Text + 343. Text.gt : Text -> Text -> Boolean + 344. Text.gteq : Text -> Text -> Boolean + 345. Text.lt : Text -> Text -> Boolean + 346. Text.lteq : Text -> Text -> Boolean + 347. Text.repeat : Nat -> Text -> Text + 348. Text.size : Text -> Nat + 349. Text.take : Nat -> Text -> Text + 350. Text.toCharList : Text -> [Char] + 351. Text.toUtf8 : Text -> Bytes + 352. Text.uncons : Text -> Optional (Char, Text) + 353. Text.unsnoc : Text -> Optional (Text, Char) + 354. todo : a -> b + 355. structural type Tuple a b + 356. Tuple.Cons : a -> b -> Tuple a b + 357. structural type Unit + 358. Unit.Unit : () + 359. Universal.< : a -> a -> Boolean + 360. Universal.<= : a -> a -> Boolean + 361. Universal.== : a -> a -> Boolean + 362. Universal.> : a -> a -> Boolean + 363. Universal.>= : a -> a -> Boolean + 364. Universal.compare : a -> a -> Int + 365. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 366. builtin type Value + 367. Value.dependencies : Value -> [Term] + 368. Value.deserialize : Bytes -> Either Text Value + 369. Value.load : Value ->{IO} Either [Term] a + 370. Value.serialize : Value -> Bytes + 371. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -465,17 +467,17 @@ Let's try it! Added definitions: - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.fromText : Text -> Optional Float + 2. Float.gt : Float -> Float -> Boolean + 3. Float.gteq : Float -> Float -> Boolean + 4. Float.log : Float -> Float + 5. Float.logBase : Float -> Float -> Float + 6. Float.lt : Float -> Float -> Boolean + 7. Float.lteq : Float -> Float -> Boolean + 8. Float.max : Float -> Float -> Float + 9. Float.min : Float -> Float -> Float + 10. Float.pow : Float -> Float -> Float + 11. Float.round : Float -> Int Tip: You can use `undo` or `reflog` to undo this change. @@ -535,17 +537,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.gteq : Float -> Float -> Boolean - 2. Float.log : Float -> Float - 3. Float.logBase : Float -> Float -> Float - 4. Float.lt : Float -> Float -> Boolean - 5. Float.lteq : Float -> Float -> Boolean - 6. Float.max : Float -> Float -> Float - 7. Float.min : Float -> Float -> Float - 8. Float.pow : Float -> Float -> Float - 9. Float.round : Float -> Int - 10. Float.sin : Float -> Float - 11. Float.sinh : Float -> Float + 1. Float.fromText : Text -> Optional Float + 2. Float.gt : Float -> Float -> Boolean + 3. Float.gteq : Float -> Float -> Boolean + 4. Float.log : Float -> Float + 5. Float.logBase : Float -> Float -> Float + 6. Float.lt : Float -> Float -> Boolean + 7. Float.lteq : Float -> Float -> Boolean + 8. Float.max : Float -> Float -> Float + 9. Float.min : Float -> Float -> Float + 10. Float.pow : Float -> Float -> Float + 11. Float.round : Float -> Int 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 1a86c24a46..e494f7e49d 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -18,7 +18,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 7. Char (builtin type) 8. Char/ (3 definitions) 9. Code (builtin type) - 10. Code/ (6 definitions) + 10. Code/ (8 definitions) 11. Debug/ (1 definition) 12. Doc (type) 13. Doc/ (6 definitions) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index f02fea7be8..1110bf8384 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (369 definitions) + 1. builtin/ (371 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (537 definitions) + 1. builtin/ (539 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index d1fa5cfb1d..eb04152984 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #70d068se1n + ⊙ #coln4ki21h - Deletes: feature1.y - ⊙ #b38gm3a91g + ⊙ #etl0g2jan9 + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #2mafeu0qi9 + ⊙ #eltot8d9mh + Adds / updates: feature1.y - ⊙ #o0i3gspbka + ⊙ #5sh9jcb1co > Moves: Original name New name x master.x - ⊙ #impsqkntjo + ⊙ #03k29v499d + Adds / updates: x - □ #8eh9l1p8vo (start of history) + □ #4jo5eu27d3 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index daa939ae9b..b6db96fcc9 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #chv8uql7m1 .old` to make an old namespace + `fork #su3tr74f51 .old` to make an old namespace accessible again, - `reset-root #chv8uql7m1` to reset the root namespace and + `reset-root #su3tr74f51` to reset the root namespace and its history to that of the specified namespace. - 1. #c7p2o500b5 : add - 2. #chv8uql7m1 : add - 3. #8eh9l1p8vo : builtins.merge + 1. #9o8p6edkn7 : add + 2. #su3tr74f51 : add + 3. #4jo5eu27d3 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 85ecdf60dc..37603d3604 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #6s4ppfd04c (start of history) + □ #teddgbjr5r (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #7ms46v3pba + ⊙ #shrqbss3nj > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #2gpohro3j9 + ⊙ #s2ho11riut > Moves: Original name New name Nat.+ Nat.frobnicate - □ #6s4ppfd04c (start of history) + □ #teddgbjr5r (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #7ms46v3pba + ⊙ #shrqbss3nj > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #2gpohro3j9 + ⊙ #s2ho11riut > Moves: Original name New name Nat.+ Nat.frobnicate - □ #6s4ppfd04c (start of history) + □ #teddgbjr5r (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #6s4ppfd04c (start of history) + □ #teddgbjr5r (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #pd0uqrl239 + ⊙ #0u83fau25p - Deletes: Nat.* Nat.+ - □ #6s4ppfd04c (start of history) + □ #teddgbjr5r (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 7745fbba4be701cb6bbae0d26cb19eac90798c43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 22 Sep 2021 11:07:29 -0400 Subject: [PATCH 107/148] Fix emphasis roundtrip in docs --- parser-typechecker/src/Unison/Lexer.hs | 66 ++++---- parser-typechecker/src/Unison/TermPrinter.hs | 11 +- unison-src/transcripts-round-trip/main.md | 18 ++ .../transcripts-round-trip/main.output.md | 158 ++++++++++++------ 4 files changed, 170 insertions(+), 83 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index cf6bc3b23d..3c0349ddb4 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -342,22 +342,30 @@ lexemes' eof = P.optional space >> do isPrefixOf "}}" word || all (== '#') word - wordy ok = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do - let end = P.lookAhead $ void docClose - <|> void docOpen - <|> void (CP.satisfy isSpace) - <|> void (CP.satisfy (not . ok)) - word <- P.someTill (CP.satisfy (\ch -> not (isSpace ch) && ok ch)) end - guard (not $ reserved word) + wordy closing = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do + let end = + P.lookAhead + $ void docClose + <|> void docOpen + <|> void (CP.satisfy isSpace) + <|> void closing + word <- P.manyTill (CP.satisfy (\ch -> not (isSpace ch))) end + guard (not $ reserved word || null word) pure word - leafy ok = groupy ok gs - where - gs = link <|> externalLink <|> exampleInline <|> expr - <|> boldOrItalicOrStrikethrough ok <|> verbatim - <|> atDoc <|> wordy ok + -- escaped :: P Char + -- escaped = char '\\' *> P.choice (map char codes) + -- where + -- codes = + -- ['\\', '`', '*', '_', '{', '}', '[', ']', '(', ')', '#', '+', '-', '.', '!'] + + leafy closing = groupy closing gs + where + gs = link <|> externalLink <|> exampleInline <|> expr + <|> boldOrItalicOrStrikethrough closing <|> verbatim + <|> atDoc <|> wordy closing - leaf = leafy (const True) + leaf = leafy mzero atDoc = src <|> evalInline <|> signature <|> signatureInline where @@ -403,9 +411,9 @@ lexemes' eof = P.optional space >> do signatureLink = wrap "syntax.docEmbedSignatureLink" $ tok (symbolyId <|> wordyId) <* CP.space - groupy ok p = do + groupy closing p = do (start,p,stop) <- positioned p - after <- P.optional . P.try $ leafy ok + after <- P.optional . P.try $ leafy closing pure $ case after of Nothing -> p Just after -> @@ -486,28 +494,30 @@ lexemes' eof = P.optional space >> do verbatim <- tok $ Textual . trim <$> P.someTill CP.anyChar ([] <$ lit fence) pure (name <> verbatim) - boldOrItalicOrStrikethrough ok = do - let start = some (CP.satisfy (== '*')) <|> some (CP.satisfy (== '_')) <|> some (CP.satisfy (== '~')) - name s = if take 1 s == "~" then "syntax.docStrikethrough" - else if length s > 1 then "syntax.docBold" - else "syntax.docItalic" - (end,ch) <- P.try $ do - end@(ch:_) <- start + boldOrItalicOrStrikethrough closing = do + let start = + some (CP.satisfy (== '*')) <|> some (CP.satisfy (== '_')) <|> some + (CP.satisfy (== '~')) + name s = if take 1 s == "~" + then "syntax.docStrikethrough" + else if length s > 1 then "syntax.docBold" else "syntax.docItalic" + end <- P.try $ do + end <- start P.lookAhead (CP.satisfy (not . isSpace)) - pure (end,ch) - wrap (name end) . wrap "syntax.docParagraph" $ - join <$> P.someTill (leafy (\c -> ok c && c /= ch) <* nonNewlineSpaces) - (lit end) + pure end + wrap (name end) . wrap "syntax.docParagraph" $ join <$> P.someTill + (leafy (closing <|> (void $ lit end)) <* nonNewlineSpaces) + (lit end) externalLink = P.label "hyperlink (example: [link name](https://destination.com))" $ wrap "syntax.docNamedLink" $ do _ <- lit "[" - p <- leafies (/= ']') + p <- leafies (void $ char ']') _ <- lit "]" _ <- lit "(" target <- wrap "syntax.docGroup" . wrap "syntax.docJoin" $ - link <|> fmap join (P.some (expr <|> wordy (/= ')'))) + link <|> fmap join (P.some (expr <|> wordy (char ')'))) _ <- lit ")" pure (p <> target) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 644214debe..c381253c9f 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -1342,7 +1342,16 @@ prettyDoc2 ppe ac tm = case tm of (toDocItalic ppe -> Just d) -> PP.group $ "*" <> rec d <> "*" (toDocBold ppe -> Just d) -> - PP.group $ "__" <> rec d <> "__" + let inner = rec d + numUnderscores = + case + filter (\s -> take 2 s == "__") + $ group (PP.toPlainUnbroken $ PP.syntaxToColor inner) + of + [] -> 2 + x -> 1 + (maximum $ map length x) + underscores = replicate numUnderscores '_' + in PP.group $ PP.string underscores <> inner <> PP.string underscores (toDocStrikethrough ppe -> Just d) -> PP.group $ "~~" <> rec d <> "~~" (toDocGroup ppe -> Just d) -> diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index cf18aaec7c..43e6fcffac 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -152,3 +152,21 @@ foo = .> load scratch.u ``` +## Emphasis in docs inserts the right number of underscores + +Regression test for https://github.com/unisonweb/unison/issues/2408 + +```unison:hide +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ }} +``` + +```ucm +.> add +.> edit myDoc +.> undo +``` + +``` ucm +.> load scratch.u +``` + diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index c933dddec8..ff69196928 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -34,15 +34,15 @@ x = 1 + 1 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #8rn1an5gj8 : add - 2. #pqvd5behc2 : builtins.mergeio + 1. #agadr8gg6g : add + 2. #bt17giel42 : builtins.mergeio 3. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #dbvse9969b : add - 2. #pqvd5behc2 : reset-root #pqvd5behc2 - 3. #8rn1an5gj8 : add - 4. #pqvd5behc2 : builtins.mergeio + 1. #rhf1s808fb : add + 2. #bt17giel42 : reset-root #bt17giel42 + 3. #agadr8gg6g : add + 4. #bt17giel42 : builtins.mergeio 5. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -191,19 +191,19 @@ f x = let most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #clsum27pr1 : add - 2. #pqvd5behc2 : reset-root #pqvd5behc2 - 3. #dbvse9969b : add - 4. #pqvd5behc2 : reset-root #pqvd5behc2 - 5. #8rn1an5gj8 : add - 6. #pqvd5behc2 : builtins.mergeio + 1. #gj5agagj7s : add + 2. #bt17giel42 : reset-root #bt17giel42 + 3. #rhf1s808fb : add + 4. #bt17giel42 : reset-root #bt17giel42 + 5. #agadr8gg6g : add + 6. #bt17giel42 : builtins.mergeio 7. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -273,21 +273,21 @@ h xs = match xs with most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #acngtb04a8 : add - 2. #pqvd5behc2 : reset-root #pqvd5behc2 - 3. #clsum27pr1 : add - 4. #pqvd5behc2 : reset-root #pqvd5behc2 - 5. #dbvse9969b : add - 6. #pqvd5behc2 : reset-root #pqvd5behc2 - 7. #8rn1an5gj8 : add - 8. #pqvd5behc2 : builtins.mergeio + 1. #3igmh2it4p : add + 2. #bt17giel42 : reset-root #bt17giel42 + 3. #gj5agagj7s : add + 4. #bt17giel42 : reset-root #bt17giel42 + 5. #rhf1s808fb : add + 6. #bt17giel42 : reset-root #bt17giel42 + 7. #agadr8gg6g : add + 8. #bt17giel42 : builtins.mergeio 9. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -353,23 +353,23 @@ foo n _ = n most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #j32i1remee : add - 2. #pqvd5behc2 : reset-root #pqvd5behc2 - 3. #acngtb04a8 : add - 4. #pqvd5behc2 : reset-root #pqvd5behc2 - 5. #clsum27pr1 : add - 6. #pqvd5behc2 : reset-root #pqvd5behc2 - 7. #dbvse9969b : add - 8. #pqvd5behc2 : reset-root #pqvd5behc2 - 9. #8rn1an5gj8 : add - 10. #pqvd5behc2 : builtins.mergeio + 1. #jsnoueu9le : add + 2. #bt17giel42 : reset-root #bt17giel42 + 3. #3igmh2it4p : add + 4. #bt17giel42 : reset-root #bt17giel42 + 5. #gj5agagj7s : add + 6. #bt17giel42 : reset-root #bt17giel42 + 7. #rhf1s808fb : add + 8. #bt17giel42 : reset-root #bt17giel42 + 9. #agadr8gg6g : add + 10. #bt17giel42 : builtins.mergeio 11. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -432,25 +432,25 @@ foo = most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #pqvd5behc2 .old` to make an old namespace + `fork #bt17giel42 .old` to make an old namespace accessible again, - `reset-root #pqvd5behc2` to reset the root namespace and + `reset-root #bt17giel42` to reset the root namespace and its history to that of the specified namespace. - 1. #o6r7803627 : add - 2. #pqvd5behc2 : reset-root #pqvd5behc2 - 3. #j32i1remee : add - 4. #pqvd5behc2 : reset-root #pqvd5behc2 - 5. #acngtb04a8 : add - 6. #pqvd5behc2 : reset-root #pqvd5behc2 - 7. #clsum27pr1 : add - 8. #pqvd5behc2 : reset-root #pqvd5behc2 - 9. #dbvse9969b : add - 10. #pqvd5behc2 : reset-root #pqvd5behc2 - 11. #8rn1an5gj8 : add - 12. #pqvd5behc2 : builtins.mergeio + 1. #vbmanbqtlh : add + 2. #bt17giel42 : reset-root #bt17giel42 + 3. #jsnoueu9le : add + 4. #bt17giel42 : reset-root #bt17giel42 + 5. #3igmh2it4p : add + 6. #bt17giel42 : reset-root #bt17giel42 + 7. #gj5agagj7s : add + 8. #bt17giel42 : reset-root #bt17giel42 + 9. #rhf1s808fb : add + 10. #bt17giel42 : reset-root #bt17giel42 + 11. #agadr8gg6g : add + 12. #bt17giel42 : builtins.mergeio 13. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -470,3 +470,53 @@ foo = foo : Text ``` +## Emphasis in docs inserts the right number of underscores + +Regression test for https://github.com/unisonweb/unison/issues/2408 + +```unison +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ }} +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + myDoc : Doc2 + +.> edit myDoc + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + myDoc : Doc2 + myDoc = + {{ __my text__ __my text__ __MY_TEXT__ ___MY__TEXT___ }} + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> undo + + Here are the changes I undid + + Added definitions: + + 1. myDoc : Doc2 + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + myDoc : Doc2 + +``` From bce149eca56e82af3b3cdecaf94f6d71b4a2bd52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 22 Sep 2021 12:20:56 -0400 Subject: [PATCH 108/148] Add failing test --- unison-src/transcripts-round-trip/main.md | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index cf18aaec7c..dfc00071bb 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -152,3 +152,24 @@ foo = .> load scratch.u ``` +## Parenthesized let-block with operator + +Regression test for https://github.com/unisonweb/unison/issues/1778 + +```unison:hide +x = '(let + abort + 0) |> Abort.toOptional +``` + +```ucm +.> add +.> edit x +.> undo +``` + +``` ucm +.> load scratch.u +``` + + From f3016d16367a91e2da847a4ba31a394686c72921 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 22 Sep 2021 11:07:24 -0500 Subject: [PATCH 109/148] Added better diagnostics when compilation fails with missing data case --- parser-typechecker/src/Unison/Runtime/MCode.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/MCode.hs b/parser-typechecker/src/Unison/Runtime/MCode.hs index 2e2000b781..e14620a421 100644 --- a/parser-typechecker/src/Unison/Runtime/MCode.hs +++ b/parser-typechecker/src/Unison/Runtime/MCode.hs @@ -741,7 +741,7 @@ emitSection rns grpn rec ctx (TMatch v bs) | Just (i,BX) <- ctxResolve ctx v , MatchData r cs df <- bs = Ins (Unpack (Just r) i) - <$> emitDataMatching rns grpn rec ctx cs df + <$> emitDataMatching r rns grpn rec ctx cs df | Just (i,BX) <- ctxResolve ctx v , MatchRequest hs0 df <- bs , hs <- mapFromList $ first (dnum rns) <$> M.toList hs0 @@ -1122,21 +1122,22 @@ emitBP2 p a emitDataMatching :: Var v - => RefNums + => Reference + -> RefNums -> Word64 -> RCtx v -> Ctx v -> EnumMap CTag ([Mem], ANormal v) -> Maybe (ANormal v) -> Emit Section -emitDataMatching rns grpn rec ctx cs df +emitDataMatching r rns grpn rec ctx cs df = MatchW 0 <$> edf <*> traverse (emitCase rns grpn rec ctx) (coerce cs) where -- Note: this is not really accurate. A default data case needs -- stack space corresponding to the actual data that shows up there. -- However, we currently don't use default cases for data. edf | Just co <- df = emitSection rns grpn rec ctx co - | otherwise = countCtx ctx $ Die "missing data case" + | otherwise = countCtx ctx $ Die ("missing data case for hash " <> show r) -- Emits code corresponding to an unboxed sum match. -- The match is against a tag on the stack, and cases introduce From 49ea7731fd7ae2069e151b36ba6f7db87058878a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 22 Sep 2021 15:23:53 -0400 Subject: [PATCH 110/148] Changes to doc basic formatting syntax. * Allow ~~ to contain ~ * Make ** bold and __ italic --- parser-typechecker/src/Unison/Lexer.hs | 2 +- parser-typechecker/src/Unison/TermPrinter.hs | 33 ++++++++++++------- unison-src/transcripts-round-trip/main.md | 2 +- .../transcripts-round-trip/main.output.md | 7 ++-- .../doc.md.files/syntax.u | 6 ++-- .../transcripts-using-base/doc.output.md | 8 ++--- 6 files changed, 35 insertions(+), 23 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 3c0349ddb4..90180949ef 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -500,7 +500,7 @@ lexemes' eof = P.optional space >> do (CP.satisfy (== '~')) name s = if take 1 s == "~" then "syntax.docStrikethrough" - else if length s > 1 then "syntax.docBold" else "syntax.docItalic" + else if take 1 s == "*" then "syntax.docBold" else "syntax.docItalic" end <- P.try $ do end <- start P.lookAhead (CP.satisfy (not . isSpace)) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index c381253c9f..ddeb27c2c2 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -1311,6 +1311,16 @@ prettyDoc2 ppe ac tm = case tm of S.DocDelimiter "}}" bail tm = brace (pretty0 ppe ac tm) + -- Finds the longest run of a character and return a run one longer than that + oneMore c inner = replicate num c + where + num = + case + filter (\s -> take 2 s == "__") + $ group (PP.toPlainUnbroken $ PP.syntaxToColor inner) + of + [] -> 2 + x -> 1 + (maximum $ map length x) go :: Width -> Term3 v PrintAnnotation -> Pretty SyntaxText go hdr = \case (toDocTransclude ppe -> Just d) -> @@ -1336,24 +1346,23 @@ prettyDoc2 ppe ac tm = case tm of (toDocWord ppe -> Just t) -> PP.text t (toDocCode ppe -> Just d) -> - PP.group ("''" <> rec d <> "''") + let inner = rec d + quotes = oneMore '\'' inner + in PP.group $ PP.string quotes <> inner <> PP.string quotes (toDocJoin ppe -> Just ds) -> foldMap rec ds (toDocItalic ppe -> Just d) -> - PP.group $ "*" <> rec d <> "*" - (toDocBold ppe -> Just d) -> let inner = rec d - numUnderscores = - case - filter (\s -> take 2 s == "__") - $ group (PP.toPlainUnbroken $ PP.syntaxToColor inner) - of - [] -> 2 - x -> 1 + (maximum $ map length x) - underscores = replicate numUnderscores '_' + underscores = oneMore '_' inner in PP.group $ PP.string underscores <> inner <> PP.string underscores + (toDocBold ppe -> Just d) -> + let inner = rec d + stars = oneMore '*' inner + in PP.group $ PP.string stars <> inner <> PP.string stars (toDocStrikethrough ppe -> Just d) -> - PP.group $ "~~" <> rec d <> "~~" + let inner = rec d + quotes = oneMore '~' inner + in PP.group $ PP.string quotes <> inner <> PP.string quotes (toDocGroup ppe -> Just d) -> PP.group $ rec d (toDocColumn ppe -> Just ds) -> diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 43e6fcffac..0cfd4d50e7 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -157,7 +157,7 @@ foo = Regression test for https://github.com/unisonweb/unison/issues/2408 ```unison:hide -myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ }} +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*TEXT** }} ``` ```ucm diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index ff69196928..cb37d5fd6d 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -475,7 +475,7 @@ foo = Regression test for https://github.com/unisonweb/unison/issues/2408 ```unison -myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ }} +myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*TEXT** }} ``` ```ucm @@ -494,7 +494,10 @@ myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ }} myDoc : Doc2 myDoc = - {{ __my text__ __my text__ __MY_TEXT__ ___MY__TEXT___ }} + {{ + **my text** __my text__ **MY_TEXT** ___MY__TEXT___ + ~~MY~TEXT~~ **MY*TEXT** + }} You can edit them there, then do `update` to replace the definitions currently in this namespace. diff --git a/unison-src/transcripts-using-base/doc.md.files/syntax.u b/unison-src/transcripts-using-base/doc.md.files/syntax.u index 10b9b02921..a34ac8d503 100644 --- a/unison-src/transcripts-using-base/doc.md.files/syntax.u +++ b/unison-src/transcripts-using-base/doc.md.files/syntax.u @@ -5,7 +5,7 @@ basicFormatting = {{ Paragraphs are separated by one or more blanklines. Sections have a title and 0 or more paragraphs or other section elements. - Text can be __bold__, *italicized*, ~~strikethrough~~, or + Text can be **bold**, __italicized__, ~~strikethrough~~, or ''monospaced''. You can link to Unison terms, types, and external URLs: @@ -20,7 +20,7 @@ basicFormatting = {{ This is useful for creating documents programmatically or just including other documents. - *Next up:* {lists} + __Next up:__ {lists} }} lists = {{ @@ -168,7 +168,7 @@ This is an aside. {{ docAside {{ Some extra detail that doesn't belong in main t docBlockquote {{ "And what is the use of a book," thought Alice, "without pictures or conversation?" - *Lewis Carroll, Alice's Adventures in Wonderland* }} + _Lewis Carroll, Alice's Adventures in Wonderland_ }} }} {{ docTooltip {{Hover over me}} {{Extra detail}} }} diff --git a/unison-src/transcripts-using-base/doc.output.md b/unison-src/transcripts-using-base/doc.output.md index badb23bbac..d8699b61f2 100644 --- a/unison-src/transcripts-using-base/doc.output.md +++ b/unison-src/transcripts-using-base/doc.output.md @@ -113,8 +113,8 @@ and the rendered output using `display`: Sections have a title and 0 or more paragraphs or other section elements. - Text can be __bold__, *italicized*, ~~strikethrough~~, or - ''monospaced''. + Text can be **bold**, __italicized__, ~~strikethrough~~, + or ''monospaced''. You can link to Unison terms, types, and external URLs: @@ -129,7 +129,7 @@ and the rendered output using `display`: useful for creating documents programmatically or just including other documents. - *Next up:* {lists} + __Next up:__ {lists} }} .> display basicFormatting @@ -469,7 +469,7 @@ and the rendered output using `display`: "And what is the use of a book," thought Alice, "without pictures or conversation?" - *Lewis Carroll, Alice's Adventures in Wonderland* + __Lewis Carroll, Alice's Adventures in Wonderland__ }} }} {{ docTooltip {{ Hover over me }} {{ Extra detail }} }} From 671397661a5f0905e24bf41d7989c797cd021455 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Wed, 22 Sep 2021 15:26:17 -0400 Subject: [PATCH 111/148] Remove commented-out code --- parser-typechecker/src/Unison/Lexer.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 90180949ef..38fb22de19 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -353,12 +353,6 @@ lexemes' eof = P.optional space >> do guard (not $ reserved word || null word) pure word - -- escaped :: P Char - -- escaped = char '\\' *> P.choice (map char codes) - -- where - -- codes = - -- ['\\', '`', '*', '_', '{', '}', '[', ']', '(', ')', '#', '+', '-', '.', '!'] - leafy closing = groupy closing gs where gs = link <|> externalLink <|> exampleInline <|> expr From 91ac3161d89e170ac53e87931c27726fae44b637 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Thu, 23 Sep 2021 09:07:33 -0400 Subject: [PATCH 112/148] wip --- .../src/Unison/CommandLine/Main.hs | 13 +- .../src/Unison/CommandLine/Welcome.hs | 228 +++++++++++++----- parser-typechecker/unison/Main.hs | 2 +- 3 files changed, 179 insertions(+), 64 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index 2f10517a53..61035ce37f 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -115,14 +115,13 @@ main -> IO () main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - (welcomeCmds, welcomeMsg) <- Welcome.welcome codebase welcome - putPrettyLn welcomeMsg + Welcome.run codebase welcome eventQueue <- Q.newIO do -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef (welcomeCmds ++ initialInputs) + initialInputsRef <- newIORef initialInputs -- Idea: Extract numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir @@ -159,9 +158,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let awaitInput = do -- use up buffered input before consulting external events - i <- readIORef initialInputsRef + i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands (case i of - h:t -> writeIORef initialInputsRef t >> pure h + h:t -> writeIORef initialInputsRef t >> pure h -- Here was where we used to write the IO of commands to the event queue. Will need to mimic in an new function [] -> -- Race the user input and file watch. Async.race (atomically $ Q.peek eventQueue) getInput >>= \case @@ -179,10 +178,10 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba cancelConfig cancelFileSystemWatch cancelWatchBranchUpdates - loop state = do + loop state = do -- I think this is the loop we should recreate or pull out. writeIORef pathRef (view HandleInput.currentPath state) let free = runStateT (runMaybeT HandleInput.loop) state - (o, state') <- HandleCommand.commandLine config awaitInput + (o, state') <- HandleCommand.commandLine config awaitInput -- This is the actual call to the interpreter fo the commands- we can recycle it (we don't need to rewrite it) (writeIORef rootRef) runtime notify diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index e593f18a7a..22085d1b1b 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -6,83 +6,155 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Prelude hiding (readFile, writeFile) import qualified Unison.Util.Pretty as P +import qualified Unison.PrettyTerminal as PT import System.Random (randomRIO) +import Unison.Codebase.Path (Path) +{- import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.Editor.Input (Input (..), Event) import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) +-} import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) --- Should Welcome include whether or not the codebase was created just now? -data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase +-- IDEAS? + +-- 1) +-- * Refactor existing IO command loop out of main function - see notes in CommandLine.main +-- * In Welcome.run; use existing interpreter to run commands +-- * Implement a silencing mechanism +-- 2) +-- * Run Codebase.importRemoteBranch directly in Welcome.runAction +-- * Merge import result into .base + +-- WELCOME data Welcome = Welcome - { downloadBase :: DownloadBase + { onboarding :: Onboarding -- Onboarding States + , downloadBase :: DownloadBase + , newCodebasePath :: Maybe FilePath , watchDir :: FilePath , unisonVersion :: String } -welcome :: Codebase IO v a -> Welcome -> IO ([Either Event Input], P.Pretty P.ColorText) -welcome codebase welcome' = do - let Welcome{downloadBase=downloadBase, watchDir=dir, unisonVersion=version} = welcome' - welcomeMsg <- welcomeMessage dir version - isBlankCodebase <- Codebase.isBlank codebase - pure $ case downloadBase of - DownloadBase ns@(_, _, path) | isBlankCodebase -> - let - cmd = - Right (pullBase ns) - - baseVersion = - P.string (show path) +-- ONBOARDING +data CodebaseInitStatus + = NewlyCreatedCodebase FilePath -- Can transition to [Base, Author, Finished] + | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. TODO: Show which codebase path was actually opened... + +data Onboarding + = Init CodebaseInitStatus -- Can transition to [Base, Author, Finished, PreviouslyOnboarded] + | Base BaseSteps -- Can transition to [Author, Finished] + | Author -- Can traisition to [Finished] + -- End States + | Finished + | PreviouslyOnboarded + +-- ucm start +-- create codebase +-- .... +-- onboarding +-- print out that we just created a codebase 56 steps earlier +-- figureout if we need to download base ... Needed a codebase and base + +-- ucm start +-- codebase already exists +-- .... +-- onboarding +-- figureout if we need to download base ... Needs base, but had an existing codebase + +-- ucm start +-- codebase exists +-- .... +-- onboarding +-- this is my 100th time and i've got a codebase, and author and base -> PreviouslyOnboarded + +data BaseSteps + = DownloadingBase ReadRemoteNamespace + | DownloadBaseFailed ReadRemoteNamespace Text + | DownloadBaseSucceeded ReadRemoteNamespace + +data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase + +welcome :: DownloadBase -> Maybe FilePath -> FilePath -> String -> Welcome +welcome downloadBase newCodebasePath watchDir unisonVersion = + case newCodebasePath of + Just path -> Welcome (Init (NewlyCreatedCodebase path)) downloadBase newCodebasePath watchDir unisonVersion + Nothing -> Welcome (Init PreviouslyCreatedCodebase) downloadBase newCodebasePath watchDir unisonVersion + +run :: Codebase IO v a -> Welcome -> IO () +run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do + go onboarding + where + go :: Onboarding -> IO () + go onboarding = + case onboarding of + Init (NewlyCreatedCodebase path) -> do + PT.putPrettyLn (header version) + PT.putPrettyLn (createdCodebase path) + + determineFirstStep >>= go + Init PreviouslyCreatedCodebase -> do + PT.putPrettyLn (header version) + + determineFirstStep >>= go + Base (DownloadingBase ns@(_, _, path)) -> do + PT.putPrettyLn $ downloading path + res <- pullBase ns + case res of + Right _ -> + go $ Base $ DownloadBaseSucceeded ns + Left errorMsg -> + go $ Base $ DownloadBaseFailed ns errorMsg + + Base (DownloadBaseSucceeded _) -> do + PT.putPrettyLn $ P.lines [ + P.wrap "✅ Success! The base library is the Unison standard library that includes", + P.wrap "core types and functions to write Unison code." + ] + -- getStarted dir >>= PT.putPrettyLn - downloadMsg = - P.lines [ P.newline <> P.newline - , P.wrap ("🕐 Downloading" - <> P.blue baseVersion - <> "of the" - <> P.bold "base library" - <> "into" - <> P.group (P.blue ".base" <> ", this may take a minute...")) - ] - in - ([cmd], welcomeMsg <> downloadMsg) - _ -> - ([], welcomeMsg) - -welcomeMessage :: FilePath -> String -> IO (P.Pretty P.ColorText) -welcomeMessage dir version = do - earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2) + go Author + Base (DownloadBaseFailed _ _) -> do + PT.putPrettyLn "Download Failed" + getStarted dir >>= PT.putPrettyLn + + Author -> do + PT.putPrettyLn "Enter your author!" + go Finished - pure $ - asciiartUnison - <> P.newline - <> P.newline - <> P.linesSpaced - [ P.wrap "👋 Welcome to Unison!", - P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline, - P.wrap "Get started:", - P.indentN - 2 - ( P.column2 - [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help " <> " to view help for one command"), - ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), - ("📚", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), - (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), - ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir)) - ] - ) - ] - -pullBase :: ReadRemoteNamespace -> Input -pullBase ns = do + Finished -> + getStarted dir >>= PT.putPrettyLn + + PreviouslyOnboarded -> + getStarted dir >>= PT.putPrettyLn + + determineFirstStep :: IO Onboarding + determineFirstStep = do + isBlankCodebase <- Codebase.isBlank codebase + case downloadBase of + DownloadBase ns | isBlankCodebase -> + pure $ Base (DownloadingBase ns) + _ -> + pure $ PreviouslyOnboarded + + + +-- HELPERS + +pullBase :: ReadRemoteNamespace -> IO (Either Text ()) +pullBase _ns = + {- let seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} - PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete + in do + -} + pure $ Right () + -- PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete asciiartUnison :: P.Pretty P.ColorText asciiartUnison = @@ -109,3 +181,47 @@ asciiartUnison = <> P.cyan "|___|" <> P.purple "_|_|" + +downloading :: Path -> P.Pretty P.ColorText +downloading path = + P.indentN 2 $ P.lines + [ P.newline <> P.newline, + P.wrap + ("🕐 Downloading" + <> P.blue (P.string (show path)) + <> "of the" + <> P.bold "base library" + <> "into" + <> P.group (P.blue ".base" <> ", this may take a minute...") + ) + ] + + +header :: String -> P.Pretty P.ColorText +header version = + asciiartUnison + <> P.newline + <> P.newline + <> P.linesSpaced + [ P.wrap "👋 Welcome to Unison!", + P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline + ] + +createdCodebase :: FilePath -> P.Pretty P.ColorText +createdCodebase dir = + P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue (P.string dir) + +getStarted :: FilePath -> IO (P.Pretty P.ColorText) +getStarted dir = do + earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2) + + pure $ P.linesSpaced [ + P.wrap "Get started:", + P.indentN 2 $ P.column2 + [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help " <> " to view help for one command"), + ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"), + ("📚", "Read the official docs at " <> P.blue "https://unisonweb.org/docs"), + (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"), + ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir)) + ] + ] \ No newline at end of file diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 5e9cfa890d..68074ed5bd 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -253,7 +253,7 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase = Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS _ -> Welcome.DontDownloadBase - welcome = Welcome.Welcome downloadBase dir Version.gitDescribe + welcome = Welcome.welcome downloadBase Nothing dir Version.gitDescribe -- TODO in CommandLine.main dir From f4cdaba953c671d38a1def13c9e7631d8e6a4a9a Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 23 Sep 2021 14:15:52 -0400 Subject: [PATCH 113/148] split out Hashing.V2 and use that for the application it's not finalized yet; it will still change when we update it to not include reference cycle length --- parser-typechecker/src/Unison/Builtin.hs | 5 +- .../src/Unison/Builtin/Decls.hs | 9 +- .../src/Unison/Builtin/Terms.hs | 6 +- parser-typechecker/src/Unison/Codebase.hs | 61 +- .../src/Unison/Codebase/CodeLookup/Util.hs | 43 +- .../src/Unison/Codebase/Editor/AuthorInfo.hs | 96 +- .../Unison/Codebase/Editor/HandleCommand.hs | 69 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 11 +- .../src/Unison/Codebase/Editor/Propagate.hs | 11 +- .../src/Unison/Codebase/Editor/SlurpResult.hs | 4 +- .../src/Unison/Codebase/Runtime.hs | 34 +- .../src/Unison/Codebase/SqliteCodebase.hs | 2 + .../src/Unison/Codebase/Type.hs | 3 + parser-typechecker/src/Unison/DeclPrinter.hs | 6 +- .../src/Unison/Hashing/V1/Convert.hs | 71 +- .../src/Unison/Hashing/V2/Convert.hs | 236 ++++ .../src/Unison/Hashing/V2/DataDeclaration.hs | 184 +++ .../Unison/Hashing/V2/LabeledDependency.hs | 56 + .../src/Unison/Hashing/V2/Pattern.hs | 165 +++ .../src/Unison/Hashing/V2/Reference.hs | 192 +++ .../src/Unison/Hashing/V2/Reference/Util.hs | 21 + .../src/Unison/Hashing/V2/Referent.hs | 123 ++ .../src/Unison/Hashing/V2/Term.hs | 1120 +++++++++++++++++ .../src/Unison/Hashing/V2/Type.hs | 721 +++++++++++ .../src/Unison/Runtime/IOSource.hs | 2 +- .../src/Unison/Runtime/Interface.hs | 7 +- .../src/Unison/Server/Backend.hs | 3 +- parser-typechecker/src/Unison/UnisonFile.hs | 21 +- .../src/Unison/UnisonFile/Names.hs | 14 +- .../src/Unison/UnisonFile/Type.hs | 24 +- .../tests/Unison/Test/DataDeclaration.hs | 29 +- .../tests/Unison/Test/UnisonSources.hs | 3 +- .../unison-parser-typechecker.cabal | 9 + unison-core/src/Unison/DataDeclaration.hs | 1 + 34 files changed, 3142 insertions(+), 220 deletions(-) create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Convert.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Pattern.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Reference.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Referent.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Term.hs create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Type.hs diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index e10a320803..254d4f85ef 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -46,6 +46,7 @@ import Unison.Names3 (Names(Names), Names0) import qualified Unison.Names3 as Names3 import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.Util.Relation as Rel +import qualified Unison.Hashing.V2.Convert as H type DataDeclaration v = DD.DataDeclaration v Ann type EffectDeclaration v = DD.EffectDeclaration v Ann @@ -106,7 +107,7 @@ builtinDependencies = -- a relation whose domain is types and whose range is builtin terms with that type builtinTermsByType :: Rel.Relation R.Reference Referent.Referent builtinTermsByType = - Rel.fromList [ (Type.toReference ty, Referent.Ref r) + Rel.fromList [ (H.typeToReference ty, Referent.Ref r) | (r, ty) <- Map.toList (termRefTypes @Symbol) ] -- a relation whose domain is types and whose range is builtin terms that mention that type @@ -114,7 +115,7 @@ builtinTermsByType = builtinTermsByTypeMention :: Rel.Relation R.Reference Referent.Referent builtinTermsByTypeMention = Rel.fromList [ (m, Referent.Ref r) | (r, ty) <- Map.toList (termRefTypes @Symbol) - , m <- toList $ Type.toReferenceMentions ty ] + , m <- toList $ H.typeToReferenceMentions ty ] -- The dependents of a builtin type is the set of builtin terms which -- mention that type. diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index 2bb6855f72..b24ebf9fad 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -15,7 +15,7 @@ import Unison.DataDeclaration Modifier (Structural, Unique), ) import qualified Unison.DataDeclaration as DD -import Unison.Hashing.V1.Convert (hashDecls) +import Unison.Hashing.V2.Convert (hashDecls) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -28,7 +28,6 @@ import Unison.Type (Type) import qualified Unison.Type as Type import Unison.Var (Var) import qualified Unison.Var as Var -import Control.Monad.Validate (runValidate) lookupDeclRef :: Text -> Reference lookupDeclRef str @@ -118,10 +117,10 @@ failConstructorReferent = Referent.Con testResultRef failConstructorId CT.Data builtinDataDecls :: Var v => [(v, Reference.Id, DataDeclaration v ())] builtinDataDecls = rs1 ++ rs where - rs1 = case runValidate . hashDecls (pure $ pure 1) $ Map.fromList + rs1 = case hashDecls $ Map.fromList [ (v "Link" , link) ] of Right a -> a; Left e -> error $ "builtinDataDecls: " <> show e - rs = case runValidate . hashDecls (pure $ pure 1) $ Map.fromList + rs = case hashDecls $ Map.fromList [ (v "Unit" , unit) , (v "Tuple" , tuple) , (v "Optional" , opt) @@ -307,7 +306,7 @@ builtinDataDecls = rs1 ++ rs builtinEffectDecls :: Var v => [(v, Reference.Id, DD.EffectDeclaration v ())] builtinEffectDecls = - case runValidate . hashDecls (pure $ pure 1) $ Map.fromList [ (v "Exception", exception) ] of + case hashDecls $ Map.fromList [ (v "Exception", exception) ] of Right a -> over _3 DD.EffectDeclaration <$> a Left e -> error $ "builtinEffectDecls: " <> show e where diff --git a/parser-typechecker/src/Unison/Builtin/Terms.hs b/parser-typechecker/src/Unison/Builtin/Terms.hs index c51777a97a..9057c6d0cf 100644 --- a/parser-typechecker/src/Unison/Builtin/Terms.hs +++ b/parser-typechecker/src/Unison/Builtin/Terms.hs @@ -7,6 +7,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Unison.Builtin.Decls as Decls +import qualified Unison.Hashing.V2.Convert as H import qualified Unison.Reference as Reference import Unison.Term (Term) import qualified Unison.Term as Term @@ -31,6 +32,9 @@ v :: Var v => Text -> v v = Var.named builtinTermsRef :: Var v => a -> Map v Reference.Id -builtinTermsRef a = fmap fst . Term.hashComponents . Map.fromList +builtinTermsRef a = + fmap fst + . H.hashTermComponents + . Map.fromList . fmap (\(v, tm, _tp) -> (v, tm)) $ builtinTermsSrc a diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index bf3f05022c..b3b3ec8c92 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ViewPatterns #-} module Unison.Codebase @@ -26,41 +27,41 @@ module Unison.Codebase ) where -import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), SyncToDir, GitError (GitCodebaseError)) -import Unison.CodebasePath (CodebasePath, getCodebaseDir) -import Unison.Prelude -import qualified Unison.UnisonFile as UF -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) import Control.Error.Util (hush) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) import Data.List as List import qualified Data.Map as Map -import Unison.Symbol (Symbol) -import qualified Unison.Parser.Ann as Parser -import qualified Unison.Builtin.Terms as Builtin +import qualified Data.Set as Set +import U.Util.Timing (time) import qualified Unison.Builtin as Builtin +import qualified Unison.Builtin.Terms as Builtin +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) +import qualified Unison.Codebase.CodeLookup as CL +import Unison.Codebase.Editor.Git (withStatus) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import qualified Unison.Codebase.GitError as GitError +import Unison.Codebase.SyncMode (SyncMode) +import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), GitError (GitCodebaseError), SyncToDir) +import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.DataDeclaration (Decl) -import qualified Unison.Reference as Reference -import Unison.Var (Var) +import qualified Unison.DataDeclaration as DD +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Parser.Ann as Parser +import Unison.Prelude import Unison.Reference (Reference) -import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) -import Unison.Type (Type) +import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent -import qualified Unison.DataDeclaration as DD -import qualified Unison.Codebase.CodeLookup as CL -import qualified Unison.WatchKind as WK +import Unison.Symbol (Symbol) import Unison.Term (Term) +import Unison.Type (Type) +import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup)) import qualified Unison.Typechecker.TypeLookup as TL -import Unison.Typechecker.TypeLookup (TypeLookup(TypeLookup)) -import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -import Unison.Codebase.SyncMode (SyncMode) -import qualified Unison.Codebase.GitError as GitError -import U.Util.Timing (time) -import Unison.Codebase.Editor.Git (withStatus) -import qualified Data.Set as Set +import qualified Unison.UnisonFile as UF import qualified Unison.Util.Relation as Rel -import qualified Unison.Type as Type +import Unison.Var (Var) +import qualified Unison.WatchKind as WK -- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep -- If not found, attempt to find it in the Codebase (sqlite) @@ -116,7 +117,9 @@ addDefsToCodebase c uf = do traverse_ goTerm (UF.hashTermsId uf) where goTerm t | debug && trace ("Codebase.addDefsToCodebase.goTerm " ++ show t) False = undefined - goTerm (r, tm, tp) = putTerm c r tm tp + goTerm (r, Nothing, tm, tp) = putTerm c r tm tp + goTerm (r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp + goTerm _ = pure () goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> m () goType _f pair | debug && trace ("Codebase.addDefsToCodebase.goType " ++ show pair) False = undefined goType f (ref, decl) = putTypeDeclaration c ref (f decl) @@ -186,16 +189,14 @@ termsOfType c ty = Set.union (Rel.lookupDom r Builtin.builtinTermsByType) . Set.map (fmap Reference.DerivedId) <$> termsOfTypeImpl c r - where - r = Type.toReference ty + where r = Hashing.typeToReference ty termsMentioningType :: (Var v, Functor m) => Codebase m v a -> Type v a -> m (Set Referent.Referent) termsMentioningType c ty = Set.union (Rel.lookupDom r Builtin.builtinTermsByTypeMention) . Set.map (fmap Reference.DerivedId) <$> termsMentioningTypeImpl c r - where - r = Type.toReference ty + where r = Hashing.typeToReference ty -- todo: could have a way to look this up just by checking for a file rather than loading it isTerm :: (Applicative m, Var v, BuiltinAnnotation a) diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs index ce7ce0150d..0f33aad54b 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs @@ -1,26 +1,35 @@ -module Unison.Codebase.CodeLookup.Util where +{-# LANGUAGE ScopedTypeVariables #-} -import Unison.Prelude +module Unison.Codebase.CodeLookup.Util where import qualified Data.Map as Map import Unison.Codebase.CodeLookup +import qualified Unison.DataDeclaration as DataDeclaration +import Unison.Prelude import qualified Unison.Reference as Reference import qualified Unison.Term as Term import qualified Unison.UnisonFile as UF -import Unison.UnisonFile.Type (UnisonFile) +import Unison.UnisonFile.Type (TypecheckedUnisonFile) import Unison.Var (Var) -fromUnisonFile :: (Var v, Monad m) => UnisonFile v a -> CodeLookup v m a -fromUnisonFile uf = CodeLookup tm ty where - tm id = pure $ Map.lookup id termMap - ty id = pure $ Map.lookup id typeMap1 <|> Map.lookup id typeMap2 - typeMap1 = Map.fromList [ (id, Right dd) | - (_, (Reference.DerivedId id, dd)) <- - Map.toList (UF.dataDeclarations uf) ] - typeMap2 = Map.fromList [ (id, Left ad) | - (_, (Reference.DerivedId id, ad)) <- - Map.toList (UF.effectDeclarations uf) ] - tmm = Map.fromList (UF.terms uf) - termMap = Map.fromList [ (id, e) | - (_, (id, e)) <- - Map.toList (Term.hashComponents tmm) ] +fromTypecheckedUnisonFile :: forall m v a. (Var v, Monad m) => TypecheckedUnisonFile v a -> CodeLookup v m a +fromTypecheckedUnisonFile tuf = CodeLookup tm ty + where + tm :: Reference.Id -> m (Maybe (Term.Term v a)) + tm id = pure $ Map.lookup id termMap + ty :: Reference.Id -> m (Maybe (DataDeclaration.Decl v a)) + ty id = pure $ Map.lookup id dataDeclMap <|> Map.lookup id effectDeclMap + dataDeclMap = + Map.fromList + [ (id, Right dd) + | (_, (Reference.DerivedId id, dd)) <- + Map.toList (UF.dataDeclarations' tuf) + ] + effectDeclMap = + Map.fromList + [ (id, Left ad) + | (_, (Reference.DerivedId id, ad)) <- + Map.toList (UF.effectDeclarations' tuf) + ] + termMap :: Map Reference.Id (Term.Term v a) + termMap = Map.fromList [(id, tm) | (id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf] diff --git a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs index 079bf14a95..638d672187 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/AuthorInfo.hs @@ -2,58 +2,68 @@ module Unison.Codebase.Editor.AuthorInfo where -import Unison.Term (Term) -import Unison.Hashing.V1.Convert (hashTermComponents) -import qualified Unison.Reference as Reference -import Unison.Prelude (MonadIO, Word8) -import Unison.Var (Var) -import Data.ByteString (unpack) import Crypto.Random (getRandomBytes) +import Data.ByteString (unpack) +import qualified Data.Foldable as Foldable import qualified Data.Map as Map -import qualified Unison.Var as Var -import Data.Foldable (toList) -import UnliftIO (liftIO) +import Data.Text (Text) +import qualified Unison.Hashing.V2.Convert as H +import Unison.Prelude (MonadIO, Word8) +import qualified Unison.Reference as Reference +import Unison.Term (Term) import qualified Unison.Term as Term -import qualified Unison.Type as Type import Unison.Type (Type) -import Data.Text (Text) +import qualified Unison.Type as Type +import Unison.Var (Var) +import qualified Unison.Var as Var +import UnliftIO (liftIO) data AuthorInfo v a = AuthorInfo - { guid, author, copyrightHolder :: (Reference.Id, Term v a, Type v a) } + {guid, author, copyrightHolder :: (Reference.Id, Term v a, Type v a)} createAuthorInfo :: forall m v a. MonadIO m => Var v => a -> Text -> m (AuthorInfo v a) createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32) where - createAuthorInfo' :: [Word8] -> AuthorInfo v a - createAuthorInfo' bytes = let - [(guidRef, guidTerm)] = hashAndWrangle "guid" $ - Term.app a - (Term.constructor a guidTypeRef 0) - (Term.app a - (Term.builtin a "Bytes.fromList") - (Term.list a (map (Term.nat a . fromIntegral) bytes))) - - [(authorRef, authorTerm)] = hashAndWrangle "author" $ - Term.apps - (Term.constructor a authorTypeRef 0) - [(a, Term.ref a (Reference.DerivedId guidRef)) - ,(a, Term.text a t)] + createAuthorInfo' :: [Word8] -> AuthorInfo v a + createAuthorInfo' bytes = + let [(guidRef, guidTerm)] = + hashAndWrangle "guid" $ + Term.app + a + (Term.constructor a guidTypeRef 0) + ( Term.app + a + (Term.builtin a "Bytes.fromList") + (Term.list a (map (Term.nat a . fromIntegral) bytes)) + ) - [(chRef, chTerm)] = hashAndWrangle "copyrightHolder" $ - Term.apps - (Term.constructor a chTypeRef 0) - [(a, Term.ref a (Reference.DerivedId guidRef)) - ,(a, Term.text a t)] + [(authorRef, authorTerm)] = + hashAndWrangle "author" $ + Term.apps + (Term.constructor a authorTypeRef 0) + [ (a, Term.ref a (Reference.DerivedId guidRef)), + (a, Term.text a t) + ] - in AuthorInfo - (guidRef, guidTerm, guidType) - (authorRef, authorTerm, authorType) - (chRef, chTerm, chType) - hashAndWrangle v tm = toList . hashTermComponents (const $ Just 1) $ Map.fromList [(Var.named v, tm)] - (chType, chTypeRef) = (Type.ref a chTypeRef, unsafeParse copyrightHolderHash) - (authorType, authorTypeRef) = (Type.ref a authorTypeRef, unsafeParse authorHash) - (guidType, guidTypeRef) = (Type.ref a guidTypeRef, unsafeParse guidHash) - unsafeParse = either error id . Reference.fromText - guidHash = "#rc29vdqe019p56kupcgkg07fkib86r3oooatbmsgfbdsgpmjhsh00l307iuts3r973q5etb61vbjkes42b6adb3mkorusvmudiuorno" - copyrightHolderHash = "#aohndsu9bl844vspujp142j5aijv86rifmnrbnjvpv3h3f3aekn45rj5s1uf1ucrrtm5urbc5d1ajtm7lqq1tr8lkgv5fathp6arqug" - authorHash = "#5hi1vvs5t1gmu6vn1kpqmgksou8ie872j31gc294lgqks71di6gm3d4ugnrr4mq8ov0ap1e20lq099d5g6jjf9c6cbp361m9r9n5g50" + [(chRef, chTerm)] = + hashAndWrangle "copyrightHolder" $ + Term.apps + (Term.constructor a chTypeRef 0) + [ (a, Term.ref a (Reference.DerivedId guidRef)), + (a, Term.text a t) + ] + in AuthorInfo + (guidRef, guidTerm, guidType) + (authorRef, authorTerm, authorType) + (chRef, chTerm, chType) + hashAndWrangle v tm = + Foldable.toList $ + H.hashTermComponents + (Map.fromList [(Var.named v, tm)]) + (chType, chTypeRef) = (Type.ref a chTypeRef, unsafeParse copyrightHolderHash) + (authorType, authorTypeRef) = (Type.ref a authorTypeRef, unsafeParse authorHash) + (guidType, guidTypeRef) = (Type.ref a guidTypeRef, unsafeParse guidHash) + unsafeParse = either error id . Reference.fromText + guidHash = "#rc29vdqe019p56kupcgkg07fkib86r3oooatbmsgfbdsgpmjhsh00l307iuts3r973q5etb61vbjkes42b6adb3mkorusvmudiuorno" + copyrightHolderHash = "#aohndsu9bl844vspujp142j5aijv86rifmnrbnjvpv3h3f3aekn45rj5s1uf1ucrrtm5urbc5d1ajtm7lqq1tr8lkgv5fathp6arqug" + authorHash = "#5hi1vvs5t1gmu6vn1kpqmgksou8ie872j31gc294lgqks71di6gm3d4ugnrr4mq8ov0ap1e20lq099d5g6jjf9c6cbp361m9r9n5g50" diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index cd8e82fdda..44322edfb1 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -9,45 +9,42 @@ module Unison.Codebase.Editor.HandleCommand where import Unison.Prelude -import Unison.Codebase.Editor.Output -import Unison.Codebase.Editor.Command - -import qualified Unison.Builtin as B - -import qualified Unison.Server.Backend as Backend -import qualified Crypto.Random as Random -import Control.Monad.Except ( runExceptT ) -import qualified Control.Monad.State as State -import qualified Data.Configurator as Config -import Data.Configurator.Types ( Config ) -import qualified Data.Map as Map -import qualified Data.Text as Text -import Unison.Codebase ( Codebase ) -import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch ( Branch ) -import qualified Unison.Codebase.Branch as Branch +import Control.Monad.Except (runExceptT) +import qualified Control.Monad.State as State +import qualified Crypto.Random as Random +import qualified Data.Configurator as Config +import Data.Configurator.Types (Config) +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Unison.Builtin as B +import Unison.Codebase (Codebase) +import qualified Unison.Codebase as Codebase +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) +import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) +import Unison.Codebase.Runtime (Runtime) +import qualified Unison.Codebase.Runtime as Runtime +import Unison.FileParsers (parseAndSynthesizeFile, synthesizeFile') +import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.Parser as Parser import Unison.Parser.Ann (Ann) -import qualified Unison.Parser as Parser -import qualified Unison.Parsers as Parsers -import qualified Unison.Reference as Reference -import qualified Unison.Codebase.Runtime as Runtime -import Unison.Codebase.Runtime (Runtime) -import qualified Unison.Server.CodebaseServer as Server -import qualified Unison.Term as Term -import qualified Unison.UnisonFile as UF -import Unison.Util.Free ( Free ) -import qualified Unison.Util.Free as Free -import Unison.Var ( Var ) +import qualified Unison.Parser.Ann as Ann +import qualified Unison.Parsers as Parsers +import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.Reference as Reference import qualified Unison.Result as Result -import Unison.FileParsers ( parseAndSynthesizeFile - , synthesizeFile' - ) -import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.Server.Backend as Backend +import qualified Unison.Server.CodebaseServer as Server import Unison.Term (Term) +import qualified Unison.Term as Term import Unison.Type (Type) -import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo -import qualified Unison.Parser.Ann as Ann +import qualified Unison.UnisonFile as UF +import Unison.Util.Free (Free) +import qualified Unison.Util.Free as Free +import Unison.Var (Var) import qualified Unison.WatchKind as WK import Web.Browser (openBrowser) @@ -201,13 +198,13 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour cache = if useCache then watchCache else Runtime.noCache r <- Runtime.evaluateTerm' codeLookup cache ppe rt tm when useCache $ case r of - Right tmr -> Codebase.putWatch codebase WK.RegularWatch (Term.hashClosedTerm tm) + Right tmr -> Codebase.putWatch codebase WK.RegularWatch (Hashing.hashClosedTerm tm) (Term.amap (const Ann.External) tmr) Left _ -> pure () pure $ r <&> Term.amap (const Ann.External) evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> _ - evalUnisonFile ppe (UF.discardTypes -> unisonFile) = do + evalUnisonFile ppe unisonFile = do let codeLookup = Codebase.toCodeLookup codebase r <- Runtime.evaluateWatches codeLookup ppe watchCache rt unisonFile case r of diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 1256b6509f..34108ff56a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -149,6 +149,7 @@ import qualified Unison.Util.Relation as Relation import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Unison.Codebase.Editor.AuthorInfo (AuthorInfo(..)) +import qualified Unison.Hashing.V2.Convert as Hashing type F m i v = Free (Command m i v) @@ -602,7 +603,7 @@ loop = do Just ty -> do let steps = bimap (Path.unabsolute . resolveToAbsolute) - (const . step $ Type.toReference ty) + (const . step $ Hashing.typeToReference ty) <$> srcs stepManyAtNoSync steps where @@ -921,7 +922,7 @@ loop = do diffHelper (Branch.head prev) (Branch.head root') >>= respondNumbered . uncurry Output.ShowDiffAfterUndo - UiI -> eval UI + UiI -> eval UI AliasTermI src dest -> do referents <- resolveHHQS'Referents src @@ -1430,7 +1431,7 @@ loop = do where n = Name.fromVar v hashTerms :: Map Reference (Type v Ann) hashTerms = Map.fromList (toList hashTerms0) where - hashTerms0 = (\(r, _, typ) -> (r, typ)) <$> UF.hashTerms uf + hashTerms0 = (\(r, _wk, _tm, typ) -> (r, typ)) <$> UF.hashTerms uf termEdits :: Map Name (Reference, Reference) termEdits = Map.fromList $ map g (toList $ SC.terms (updates sr)) where g v = case ( toList (Names.refTermsNamed slurpCheckNames0 n) @@ -1757,7 +1758,7 @@ loop = do datas, effects, terms :: [(Name, Reference.Id)] datas = [ (Name.fromVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf ] effects = [ (Name.fromVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf ] - terms = [ (Name.fromVar v, r) | (v, (r, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf ] + terms = [ (Name.fromVar v, r) | (v, (r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf ] in eval . Notify $ DumpUnisonFileHashes hqLength datas effects terms DebugDumpNamespacesI -> do let seen h = State.gets (Set.member h) @@ -1926,7 +1927,7 @@ getLinks input src mdTypeStr = ExceptT $ do Right Nothing -> go Nothing Right (Just mdTypeStr) -> parseType input mdTypeStr >>= \case Left e -> pure $ Left e - Right typ -> go . Just . Set.singleton $ Type.toReference typ + Right typ -> go . Just . Set.singleton $ Hashing.typeToReference typ getLinks' :: (Var v, Monad m) => Path.HQSplit' -- definition to print metadata of diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs index 07034a5e10..0833ecdcf9 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Propagate.hs @@ -50,9 +50,10 @@ import Unison.UnisonFile ( UnisonFile(..) ) import qualified Unison.UnisonFile as UF import qualified Unison.Util.Star3 as Star3 import Unison.Type ( Type ) -import qualified Unison.Type as Type import qualified Unison.Typechecker as Typechecker import qualified Unison.Runtime.IOSource as IOSource +import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.WatchKind (WatchKind) type F m i v = Free (Command m i v) @@ -323,7 +324,7 @@ propagate rootNames patch b = case validatePatch patch of declMap = over _2 (either Decl.toDataDecl id) <$> componentMap' -- TODO: kind-check the new components hashedDecls = (fmap . fmap) (over _2 DerivedId) - . Decl.hashDecls + . Hashing.hashDecls $ view _2 <$> declMap hashedComponents' <- case hashedDecls of Left _ -> @@ -392,7 +393,7 @@ propagate rootNames patch b = case validatePatch patch of let joinedStuff = toList (Map.intersectionWith f componentMap componentMap'') - f (oldRef, _oldTerm, oldType) (newRef, newTerm, newType) = + f (oldRef, _oldTerm, oldType) (newRef, _newWatchKind, newTerm, newType) = (oldRef, newRef, newTerm, oldType, newType') -- Don't replace the type if it hasn't changed. @@ -494,7 +495,7 @@ propagate rootNames patch b = case validatePatch patch of verifyTermComponent :: Map v (Reference, Term v _, a) -> Edits v - -> F m i v (Maybe (Map v (Reference, Term v _, Type v _))) + -> F m i v (Maybe (Map v (Reference, Maybe WatchKind, Term v _, Type v _))) verifyTermComponent componentMap Edits {..} = do -- If the term contains references to old patterns, we can't update it. -- If the term had a redunant type signature, it's discarded and a new type @@ -562,7 +563,7 @@ applyDeprecations patch = deleteDeprecatedTerms deprecatedTerms applyPropagate :: Var v => Applicative m => Patch -> Edits v -> F m i v (Branch0 m -> Branch0 m) applyPropagate patch Edits {..} = do - let termTypes = Map.map (Type.toReference . snd) newTerms + let termTypes = Map.map (Hashing.typeToReference . snd) newTerms -- recursively update names and delete deprecated definitions pure $ Branch.stepEverywhere (updateLevel termReplacements typeReplacements termTypes) where diff --git a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs index 5fea36a63d..c765f5f523 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/SlurpResult.hs @@ -233,7 +233,7 @@ pretty isPast ppe sr = okTerm v = case Map.lookup v tms of Nothing -> [(P.bold (prettyVar v), Just $ P.red "(Unison bug, unknown term)")] - Just (_, _, ty) -> + Just (_, _, _, ty) -> ( plus <> P.bold (prettyVar v) , Just $ ": " <> P.indentNAfterNewline 2 (TP.pretty ppe ty) ) @@ -280,7 +280,7 @@ pretty isPast ppe sr = <$> toList (types (defsWithBlockedDependencies sr)) ) termLineFor status v = case Map.lookup v tms of - Just (_ref, _tm, ty) -> + Just (_ref, _wk, _tm, ty) -> ( prettyStatus status , P.bold (P.text $ Var.name v) , ": " <> P.indentNAfterNewline 6 (TP.pretty ppe ty) diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 6dcafafaef..5671a5245b 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -5,20 +5,19 @@ module Unison.Codebase.Runtime where import Unison.Prelude -import Data.Bifunctor (first) import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Unison.ABT as ABT import Unison.Builtin.Decls (tupleTerm, pattern TupleTerm') import qualified Unison.Codebase.CodeLookup as CL import qualified Unison.Codebase.CodeLookup.Util as CL +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.Parser.Ann (Ann) import qualified Unison.PrettyPrintEnv as PPE import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Term as Term import Unison.Type (Type) -import Unison.UnisonFile (UnisonFile) +import Unison.UnisonFile (TypecheckedUnisonFile) import qualified Unison.UnisonFile as UF import qualified Unison.Util.Pretty as P import Unison.Var (Var) @@ -67,17 +66,17 @@ evaluateWatches -> PPE.PrettyPrintEnv -> (Reference -> IO (Maybe (Term v))) -> Runtime v - -> UnisonFile v a + -> TypecheckedUnisonFile v a -> IO (WatchResults v a) -evaluateWatches code ppe evaluationCache rt uf = do +evaluateWatches code ppe evaluationCache rt tuf = do -- 1. compute hashes for everything in the file let m :: Map v (Reference, Term.Term v a) - m = first Reference.DerivedId <$> - Term.hashComponents (Map.fromList (UF.terms uf <> UF.allWatches uf)) - watches = Set.fromList (fst <$> UF.allWatches uf) + m = fmap (\(id, _wk, tm, _tp) -> (Reference.DerivedId id, tm)) (UF.hashTermsId tuf) + watches :: Set v = Map.keysSet watchKinds watchKinds :: Map v WatchKind - watchKinds = Map.fromList [ (v, k) | (k, ws) <- Map.toList (UF.watches uf) - , (v,_) <- ws ] + watchKinds = + Map.fromList + [(v, k) | (k, ws) <- UF.watchComponents tuf, (v, _tm, _tp) <- ws] unann = Term.amap (const ()) -- 2. use the cache to lookup things already computed m' <- fmap Map.fromList . for (Map.toList m) $ \(v, (r, t)) -> do @@ -92,7 +91,7 @@ evaluateWatches code ppe evaluationCache rt uf = do bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ] watchVars = [ Term.var () v | v <- toList watches ] bigOl'LetRec = Term.letRec' True bindings (tupleTerm watchVars) - cl = void $ CL.fromUnisonFile uf <> code + cl = void (CL.fromTypecheckedUnisonFile tuf) <> void code -- 4. evaluate it and get all the results out of the tuple, then -- create the result Map out <- evaluate rt cl ppe bigOl'LetRec @@ -129,14 +128,19 @@ evaluateTerm' -> Term.Term v a -> IO (Either Error (Term v)) evaluateTerm' codeLookup cache ppe rt tm = do - let ref = Reference.DerivedId (Term.hashClosedTerm tm) + let ref = Reference.DerivedId (Hashing.hashClosedTerm tm) result <- cache ref case result of Just r -> pure (Right r) Nothing -> do - let uf = UF.UnisonFileId mempty mempty mempty - (Map.singleton WK.RegularWatch [(Var.nameds "result", tm)]) - r <- evaluateWatches codeLookup ppe cache rt uf + let + -- v = Var.nameds "result" + -- k = WK.RegularWatch + -- term = tm + -- tp = mainType rt + tuf = UF.typecheckedUnisonFile mempty mempty mempty + [(WK.RegularWatch, [(Var.nameds "result", tm, mempty <$> mainType rt)])] + r <- evaluateWatches (void codeLookup) ppe cache rt (void tuf) pure $ r <&> \(_,map) -> let [(_loc, _kind, _hash, _src, value, _isHit)] = Map.elems map in value diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 46dc0f0abd..35d4ad1edf 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -742,6 +742,8 @@ sqliteCodebase debugName root = do (Cache.applyDefined declCache getTypeDeclaration) putTerm putTypeDeclaration + (runDB conn . getCycleLen "Codebase.getTermComponentLength") + (runDB conn . getCycleLen "Codebase.getDeclComponentLength") (getRootBranch rootBranchCache) (putRootBranch rootBranchCache) (rootBranchUpdates rootBranchCache) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 01b6600c6b..6a36beb38e 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -22,6 +22,7 @@ import Unison.Type (Type) import qualified Unison.WatchKind as WK import Unison.Codebase.GitError (GitProtocolError, GitCodebaseError) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError) +import Unison.Hash (Hash) type SyncToDir m = CodebasePath -> -- dest codebase @@ -38,6 +39,8 @@ data Codebase m v a = Codebase getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), putTerm :: Reference.Id -> Term v a -> Type v a -> m (), putTypeDeclaration :: Reference.Id -> Decl v a -> m (), + getTermComponentLength :: Hash -> m Reference.Size, + getDeclComponentLength :: Hash -> m Reference.Size, getRootBranch :: m (Either GetRootBranchError (Branch m)), putRootBranch :: Branch m -> m (), rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), diff --git a/parser-typechecker/src/Unison/DeclPrinter.hs b/parser-typechecker/src/Unison/DeclPrinter.hs index 070c0af1a6..40bda7df95 100644 --- a/parser-typechecker/src/Unison/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/DeclPrinter.hs @@ -13,6 +13,7 @@ import Unison.DataDeclaration ( DataDeclaration ) import qualified Unison.DataDeclaration as DD import qualified Unison.ConstructorType as CT +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.HashQualified ( HashQualified ) import qualified Unison.HashQualified as HQ import qualified Unison.Name as Name @@ -23,7 +24,6 @@ import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Referent as Referent import Unison.Reference ( Reference(DerivedId) ) import qualified Unison.Util.SyntaxText as S -import qualified Unison.Term as Term import qualified Unison.Type as Type import qualified Unison.TypePrinter as TypePrinter import Unison.Util.Pretty ( Pretty ) @@ -138,7 +138,7 @@ fieldNames env r name dd = case DD.constructors dd of vars :: [v] vars = [ Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0..Type.arity typ - 1]] accessors = DD.generateRecordAccessors (map (,()) vars) (HQ.toVar name) r - hashes = Term.hashComponents (Map.fromList accessors) + hashes = Hashing.hashTermComponents (Map.fromList accessors) names = [ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r) | r <- fst <$> Map.elems hashes ] fieldNames = Map.fromList @@ -158,7 +158,7 @@ fieldNames env r name dd = case DD.constructors dd of _ -> Nothing prettyModifier :: DD.Modifier -> Pretty SyntaxText -prettyModifier DD.Structural = fmt S.DataTypeModifier "structural" +prettyModifier DD.Structural = fmt S.DataTypeModifier "structural" prettyModifier (DD.Unique _uid) = fmt S.DataTypeModifier "unique" -- <> ("[" <> P.text uid <> "] ") diff --git a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs index 8041c9c4c4..3b7efb671c 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Convert.hs @@ -1,6 +1,19 @@ {-# LANGUAGE ViewPatterns #-} -module Unison.Hashing.V1.Convert (hashDecls, hashTermComponents, hashTypeComponents) where +module Unison.Hashing.V1.Convert + ( HashingInfo(..), + ResolutionFailure(..), + ResolutionResult, + assumeSingletonComponent, + hashDecls, + hashClosedTerm, + hashTermComponents, + hashTypeComponents, + typeToReference, + typeToReferenceMentions, + unsafe, + ) +where import Control.Lens (over, _3) import qualified Control.Lens as Lens @@ -25,6 +38,7 @@ import qualified Unison.Referent as Memory.Referent import qualified Unison.Term as Memory.Term import qualified Unison.Type as Memory.Type import Unison.Var (Var) +import qualified Data.Set as Set data ResolutionFailure v a = TermResolutionFailure v a (Set Memory.Referent.Referent) @@ -34,6 +48,8 @@ data ResolutionFailure v a type ResolutionResult v a r = Validate (Seq (ResolutionFailure v a)) r +newtype HashingInfo = HashingInfo (Hash -> Maybe Hashing.Reference.Size) + convertResolutionResult :: Names.ResolutionResult v a r -> ResolutionResult v a r convertResolutionResult = \case Left e -> Validate.refute (fmap f e) @@ -43,8 +59,24 @@ convertResolutionResult = \case Names.TermResolutionFailure v a rs -> TermResolutionFailure v a rs Names.TypeResolutionFailure v a rs -> TypeResolutionFailure v a rs +typeToReference :: + Var v => + HashingInfo -> + Memory.Type.Type v a -> + Validate (Seq Hash) Memory.Reference.Reference +typeToReference f memType = + h2mReference . Hashing.Type.toReference <$> m2hType f memType + +typeToReferenceMentions :: + Var v => + HashingInfo -> + Memory.Type.Type v a -> + Validate (Seq Hash) (Set Memory.Reference.Reference) +typeToReferenceMentions f memType = + Set.map h2mReference . Hashing.Type.toReferenceMentions <$> m2hType f memType + hashTypeComponents :: - Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) + Var v => HashingInfo -> Map v (Memory.Type.Type v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Type.Type v a)) hashTypeComponents f memTypes = do hashingTypes <- traverse (m2hType f) memTypes let hashingResult = Hashing.Type.hashComponents hashingTypes @@ -53,7 +85,16 @@ hashTypeComponents f memTypes = do h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp) -hashTermComponents :: Var v => (Hash -> Maybe Hashing.Reference.Size) -> Map v (Memory.Term.Term v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Term.Term v a)) +assumeSingletonComponent :: HashingInfo +assumeSingletonComponent = HashingInfo (\_ -> Just 1) + +unsafe :: Validate (Seq Hash) a -> a +unsafe v = case Validate.runValidate v of + Right a -> a + Left missing -> + error $ "unison.hashing.v1.unsafe: missing sizes for the following components: " ++ show missing + +hashTermComponents :: Var v => HashingInfo -> Map v (Memory.Term.Term v a) -> Validate (Seq Hash) (Map v (Memory.Reference.Id, Memory.Term.Term v a)) hashTermComponents f memTerms = do hashingTerms <- traverse (m2hTerm f) memTerms let hashingResult = Hashing.Term.hashComponents hashingTerms @@ -62,8 +103,10 @@ hashTermComponents f memTerms = do h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a) h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm) +hashClosedTerm :: Var v => Memory.Term.Term v a -> Memory.Reference.Id +hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . unsafe . m2hTerm assumeSingletonComponent -m2hTerm :: Ord v => (Hash -> Maybe Hashing.Reference.Size) -> Memory.Term.Term v a -> Validate (Seq Hash) (Hashing.Term.Term v a) +m2hTerm :: Ord v => HashingInfo -> Memory.Term.Term v a -> Validate (Seq Hash) (Hashing.Term.Term v a) m2hTerm f = ABT.transformM \case Memory.Term.Int i -> pure $ Hashing.Term.Int i Memory.Term.Nat n -> pure $ Hashing.Term.Nat n @@ -89,10 +132,10 @@ m2hTerm f = ABT.transformM \case Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent f r Memory.Term.TypeLink r -> Hashing.Term.TypeLink <$> m2hReference f r -m2hMatchCase :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Term.MatchCase a a1 -> Validate (Seq Hash) (Hashing.Term.MatchCase a a1) +m2hMatchCase :: HashingInfo -> Memory.Term.MatchCase a a1 -> Validate (Seq Hash) (Hashing.Term.MatchCase a a1) m2hMatchCase f (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase <$> m2hPattern f pat <*> pure m_a1 <*> pure a1 -m2hPattern :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Pattern.Pattern a -> Validate (Seq Hash) (Hashing.Pattern.Pattern a) +m2hPattern :: HashingInfo -> Memory.Pattern.Pattern a -> Validate (Seq Hash) (Hashing.Pattern.Pattern a) m2hPattern f = \case Memory.Pattern.Unbound loc -> pure $ Hashing.Pattern.Unbound loc Memory.Pattern.Var loc -> pure $ Hashing.Pattern.Var loc @@ -115,7 +158,7 @@ m2hSequenceOp = \case Memory.Pattern.Snoc -> Hashing.Pattern.Snoc Memory.Pattern.Concat -> Hashing.Pattern.Concat -m2hReferent :: (Hash -> Maybe Hashing.Reference.Size) -> Memory.Referent.Referent -> Validate (Seq Hash) Hashing.Referent.Referent +m2hReferent :: HashingInfo -> Memory.Referent.Referent -> Validate (Seq Hash) Hashing.Referent.Referent m2hReferent f = \case Memory.Referent.Ref ref -> Hashing.Referent.Ref <$> m2hReference f ref Memory.Referent.Con ref n ct -> Hashing.Referent.Con <$> m2hReference f ref <*> pure n <*> pure ct @@ -179,7 +222,7 @@ h2mReferent = \case hashDecls :: Var v => - (Hash -> Maybe Hashing.Reference.Size) -> + HashingInfo -> Map v (Memory.DD.DataDeclaration v a) -> ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] hashDecls f memDecls = do @@ -192,21 +235,21 @@ hashDecls f memDecls = do m2hDecl :: Ord v => - (Hash -> Maybe Hashing.Reference.Size) -> + HashingInfo -> Memory.DD.DataDeclaration v a -> Validate (Seq Hash) (Hashing.DD.DataDeclaration v a) m2hDecl f (Memory.DD.DataDeclaration mod ann bound ctors) = Hashing.DD.DataDeclaration (m2hModifier mod) ann bound <$> traverse (Lens.mapMOf _3 (m2hType f)) ctors -lookupHash :: (Hash -> Maybe Hashing.Reference.Size) -> Hash -> Validate (Seq Hash) Hashing.Reference.Size -lookupHash f h = case f h of +lookupHash :: HashingInfo -> Hash -> Validate (Seq Hash) Hashing.Reference.Size +lookupHash (HashingInfo f) h = case f h of Just size -> pure size Nothing -> Validate.refute $ pure h m2hType :: Ord v => - (Hash -> Maybe Hashing.Reference.Size) -> + HashingInfo -> Memory.Type.Type v a -> Validate (Seq Hash) (Hashing.Type.Type v a) m2hType f = ABT.transformM \case @@ -220,7 +263,7 @@ m2hType f = ABT.transformM \case Memory.Type.IntroOuter a1 -> pure $ Hashing.Type.IntroOuter a1 m2hReference :: - (Hash -> Maybe Hashing.Reference.Size) -> + HashingInfo -> Memory.Reference.Reference -> Validate (Seq Hash) Hashing.Reference.Reference m2hReference f = \case @@ -228,7 +271,7 @@ m2hReference f = \case Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId <$> m2hReferenceId f d m2hReferenceId :: - (Hash -> Maybe Hashing.Reference.Size) -> + HashingInfo -> Memory.Reference.Id -> Validate (Seq Hash) Hashing.Reference.Id m2hReferenceId f (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i <$> lookupHash f h diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs new file mode 100644 index 0000000000..8f642ab84f --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Convert + ( ResolutionResult, + hashDecls, + hashClosedTerm, + hashTermComponents, + hashTypeComponents, + typeToReference, + typeToReferenceMentions, + ) +where + +import Control.Lens (over, _3) +import qualified Control.Lens as Lens +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Unison.ABT as ABT +import qualified Unison.DataDeclaration as Memory.DD +import qualified Unison.Hashing.V2.DataDeclaration as Hashing.DD +import qualified Unison.Hashing.V2.Pattern as Hashing.Pattern +import qualified Unison.Hashing.V2.Reference as Hashing.Reference +import qualified Unison.Hashing.V2.Referent as Hashing.Referent +import qualified Unison.Hashing.V2.Term as Hashing.Term +import qualified Unison.Hashing.V2.Type as Hashing.Type +import Unison.Names.ResolutionResult (ResolutionResult) +import qualified Unison.Pattern as Memory.Pattern +import qualified Unison.Reference as Memory.Reference +import qualified Unison.Referent as Memory.Referent +import qualified Unison.Term as Memory.Term +import qualified Unison.Type as Memory.Type +import Unison.Var (Var) + +typeToReference :: Var v => Memory.Type.Type v a -> Memory.Reference.Reference +typeToReference = h2mReference . Hashing.Type.toReference . m2hType + +typeToReferenceMentions :: Var v => Memory.Type.Type v a -> Set Memory.Reference.Reference +typeToReferenceMentions = Set.map h2mReference . Hashing.Type.toReferenceMentions . m2hType + +hashTypeComponents :: Var v => Map v (Memory.Type.Type v a) -> Map v (Memory.Reference.Id, Memory.Type.Type v a) +hashTypeComponents = fmap h2mTypeResult . Hashing.Type.hashComponents . fmap m2hType + where + h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a) + h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp) + +hashTermComponents :: Var v => Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a) +hashTermComponents = fmap h2mTermResult . Hashing.Term.hashComponents . fmap m2hTerm + where + h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a) + h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm) + +hashClosedTerm :: Var v => Memory.Term.Term v a -> Memory.Reference.Id +hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . m2hTerm + +m2hTerm :: Ord v => Memory.Term.Term v a -> Hashing.Term.Term v a +m2hTerm = ABT.transform \case + Memory.Term.Int i -> Hashing.Term.Int i + Memory.Term.Nat n -> Hashing.Term.Nat n + Memory.Term.Float d -> Hashing.Term.Float d + Memory.Term.Boolean b -> Hashing.Term.Boolean b + Memory.Term.Text t -> Hashing.Term.Text t + Memory.Term.Char c -> Hashing.Term.Char c + Memory.Term.Blank b -> Hashing.Term.Blank b + Memory.Term.Ref r -> Hashing.Term.Ref (m2hReference r) + Memory.Term.Constructor r i -> Hashing.Term.Constructor (m2hReference r) i + Memory.Term.Request r i -> Hashing.Term.Request (m2hReference r) i + Memory.Term.Handle x y -> Hashing.Term.Handle x y + Memory.Term.App f x -> Hashing.Term.App f x + Memory.Term.Ann e t -> Hashing.Term.Ann e (m2hType t) + Memory.Term.List as -> Hashing.Term.List as + Memory.Term.And p q -> Hashing.Term.And p q + Memory.Term.If c t f -> Hashing.Term.If c t f + Memory.Term.Or p q -> Hashing.Term.Or p q + Memory.Term.Lam a -> Hashing.Term.Lam a + Memory.Term.LetRec isTop bs body -> Hashing.Term.LetRec isTop bs body + Memory.Term.Let isTop b body -> Hashing.Term.Let isTop b body + Memory.Term.Match scr cases -> Hashing.Term.Match scr (fmap m2hMatchCase cases) + Memory.Term.TermLink r -> Hashing.Term.TermLink (m2hReferent r) + Memory.Term.TypeLink r -> Hashing.Term.TypeLink (m2hReference r) + +m2hMatchCase :: Memory.Term.MatchCase a a1 -> Hashing.Term.MatchCase a a1 +m2hMatchCase (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase (m2hPattern pat) m_a1 a1 + +m2hPattern :: Memory.Pattern.Pattern a -> Hashing.Pattern.Pattern a +m2hPattern = \case + Memory.Pattern.Unbound loc -> Hashing.Pattern.Unbound loc + Memory.Pattern.Var loc -> Hashing.Pattern.Var loc + Memory.Pattern.Boolean loc b -> Hashing.Pattern.Boolean loc b + Memory.Pattern.Int loc i -> Hashing.Pattern.Int loc i + Memory.Pattern.Nat loc n -> Hashing.Pattern.Nat loc n + Memory.Pattern.Float loc f -> Hashing.Pattern.Float loc f + Memory.Pattern.Text loc t -> Hashing.Pattern.Text loc t + Memory.Pattern.Char loc c -> Hashing.Pattern.Char loc c + Memory.Pattern.Constructor loc r i ps -> Hashing.Pattern.Constructor loc (m2hReference r) i (fmap m2hPattern ps) + Memory.Pattern.As loc p -> Hashing.Pattern.As loc (m2hPattern p) + Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc (m2hPattern p) + Memory.Pattern.EffectBind loc r i ps k -> Hashing.Pattern.EffectBind loc (m2hReference r) i (fmap m2hPattern ps) (m2hPattern k) + Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc (fmap m2hPattern ps) + Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc (m2hPattern l) (m2hSequenceOp op) (m2hPattern r) + +m2hSequenceOp :: Memory.Pattern.SeqOp -> Hashing.Pattern.SeqOp +m2hSequenceOp = \case + Memory.Pattern.Cons -> Hashing.Pattern.Cons + Memory.Pattern.Snoc -> Hashing.Pattern.Snoc + Memory.Pattern.Concat -> Hashing.Pattern.Concat + +m2hReferent :: Memory.Referent.Referent -> Hashing.Referent.Referent +m2hReferent = \case + Memory.Referent.Ref ref -> Hashing.Referent.Ref (m2hReference ref) + Memory.Referent.Con ref n ct -> Hashing.Referent.Con (m2hReference ref) n ct + +h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a +h2mTerm = ABT.transform \case + Hashing.Term.Int i -> Memory.Term.Int i + Hashing.Term.Nat n -> Memory.Term.Nat n + Hashing.Term.Float d -> Memory.Term.Float d + Hashing.Term.Boolean b -> Memory.Term.Boolean b + Hashing.Term.Text t -> Memory.Term.Text t + Hashing.Term.Char c -> Memory.Term.Char c + Hashing.Term.Blank b -> Memory.Term.Blank b + Hashing.Term.Ref r -> Memory.Term.Ref (h2mReference r) + Hashing.Term.Constructor r i -> Memory.Term.Constructor (h2mReference r) i + Hashing.Term.Request r i -> Memory.Term.Request (h2mReference r) i + Hashing.Term.Handle x y -> Memory.Term.Handle x y + Hashing.Term.App f x -> Memory.Term.App f x + Hashing.Term.Ann e t -> Memory.Term.Ann e (h2mType t) + Hashing.Term.List as -> Memory.Term.List as + Hashing.Term.If c t f -> Memory.Term.If c t f + Hashing.Term.And p q -> Memory.Term.And p q + Hashing.Term.Or p q -> Memory.Term.Or p q + Hashing.Term.Lam a -> Memory.Term.Lam a + Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body + Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body + Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases) + Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent r) + Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r) + +h2mMatchCase :: Hashing.Term.MatchCase a b -> Memory.Term.MatchCase a b +h2mMatchCase (Hashing.Term.MatchCase pat m_b b) = Memory.Term.MatchCase (h2mPattern pat) m_b b + +h2mPattern :: Hashing.Pattern.Pattern a -> Memory.Pattern.Pattern a +h2mPattern = \case + Hashing.Pattern.Unbound loc -> Memory.Pattern.Unbound loc + Hashing.Pattern.Var loc -> Memory.Pattern.Var loc + Hashing.Pattern.Boolean loc b -> Memory.Pattern.Boolean loc b + Hashing.Pattern.Int loc i -> Memory.Pattern.Int loc i + Hashing.Pattern.Nat loc n -> Memory.Pattern.Nat loc n + Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f + Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t + Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c + Hashing.Pattern.Constructor loc r i ps -> Memory.Pattern.Constructor loc (h2mReference r) i (h2mPattern <$> ps) + Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p) + Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p) + Hashing.Pattern.EffectBind loc r i ps k -> Memory.Pattern.EffectBind loc (h2mReference r) i (h2mPattern <$> ps) (h2mPattern k) + Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps) + Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r) + +h2mSequenceOp :: Hashing.Pattern.SeqOp -> Memory.Pattern.SeqOp +h2mSequenceOp = \case + Hashing.Pattern.Cons -> Memory.Pattern.Cons + Hashing.Pattern.Snoc -> Memory.Pattern.Snoc + Hashing.Pattern.Concat -> Memory.Pattern.Concat + +h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent +h2mReferent = \case + Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref) + Hashing.Referent.Con ref n ct -> Memory.Referent.Con (h2mReference ref) n ct + +hashDecls :: + Var v => + Map v (Memory.DD.DataDeclaration v a) -> + ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] +hashDecls memDecls = do + let hashingDecls = fmap m2hDecl memDecls + hashingResult <- Hashing.DD.hashDecls hashingDecls + pure $ map h2mDeclResult hashingResult + where + h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) + h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd) + +m2hDecl :: Ord v => Memory.DD.DataDeclaration v a -> Hashing.DD.DataDeclaration v a +m2hDecl (Memory.DD.DataDeclaration mod ann bound ctors) = + Hashing.DD.DataDeclaration (m2hModifier mod) ann bound $ fmap (Lens.over _3 m2hType) ctors + +m2hType :: Ord v => Memory.Type.Type v a -> Hashing.Type.Type v a +m2hType = ABT.transform \case + Memory.Type.Ref ref -> Hashing.Type.Ref (m2hReference ref) + Memory.Type.Arrow a1 a1' -> Hashing.Type.Arrow a1 a1' + Memory.Type.Ann a1 ki -> Hashing.Type.Ann a1 ki + Memory.Type.App a1 a1' -> Hashing.Type.App a1 a1' + Memory.Type.Effect a1 a1' -> Hashing.Type.Effect a1 a1' + Memory.Type.Effects a1s -> Hashing.Type.Effects a1s + Memory.Type.Forall a1 -> Hashing.Type.Forall a1 + Memory.Type.IntroOuter a1 -> Hashing.Type.IntroOuter a1 + +m2hReference :: Memory.Reference.Reference -> Hashing.Reference.Reference +m2hReference = \case + Memory.Reference.Builtin t -> Hashing.Reference.Builtin t + Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId (m2hReferenceId d) + +m2hReferenceId :: Memory.Reference.Id -> Hashing.Reference.Id +m2hReferenceId (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i _n + +h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier +h2mModifier = \case + Hashing.DD.Structural -> Memory.DD.Structural + Hashing.DD.Unique text -> Memory.DD.Unique text + +m2hModifier :: Memory.DD.Modifier -> Hashing.DD.Modifier +m2hModifier = \case + Memory.DD.Structural -> Hashing.DD.Structural + Memory.DD.Unique text -> Hashing.DD.Unique text + +h2mDecl :: Ord v => Hashing.DD.DataDeclaration v a -> Memory.DD.DataDeclaration v a +h2mDecl (Hashing.DD.DataDeclaration mod ann bound ctors) = + Memory.DD.DataDeclaration (h2mModifier mod) ann bound (over _3 h2mType <$> ctors) + +h2mType :: Ord v => Hashing.Type.Type v a -> Memory.Type.Type v a +h2mType = ABT.transform \case + Hashing.Type.Ref ref -> Memory.Type.Ref (h2mReference ref) + Hashing.Type.Arrow a1 a1' -> Memory.Type.Arrow a1 a1' + Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 ki + Hashing.Type.App a1 a1' -> Memory.Type.App a1 a1' + Hashing.Type.Effect a1 a1' -> Memory.Type.Effect a1 a1' + Hashing.Type.Effects a1s -> Memory.Type.Effects a1s + Hashing.Type.Forall a1 -> Memory.Type.Forall a1 + Hashing.Type.IntroOuter a1 -> Memory.Type.IntroOuter a1 + +h2mReference :: Hashing.Reference.Reference -> Memory.Reference.Reference +h2mReference = \case + Hashing.Reference.Builtin t -> Memory.Reference.Builtin t + Hashing.Reference.DerivedId d -> Memory.Reference.DerivedId (h2mReferenceId d) + +h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id +h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n diff --git a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs new file mode 100644 index 0000000000..1867adba70 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.DataDeclaration + ( DataDeclaration (..), + EffectDeclaration (..), + Decl, + Modifier (..), + asDataDecl, + constructorType, + constructorTypes, + -- declConstructorReferents, + declDependencies, + dependencies, + bindReferences, + hashDecls, + ) +where + +import Control.Lens (over, _3) +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Show1) +import Unison.Var (Var) +import qualified Unison.ABT as ABT +import qualified Unison.ConstructorType as CT +import Unison.Hash (Hash) +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as Reference.Util +import Unison.Hashing.V2.Type (Type) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.Name as Name +import qualified Unison.Names.ResolutionResult as Names +import Unison.Prelude +-- import qualified Unison.Referent as Referent +-- import qualified Unison.Referent' as Referent' +import Prelude hiding (cycle) + +type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) + +data DeclOrBuiltin v a + = Builtin CT.ConstructorType + | Decl (Decl v a) + deriving (Eq, Show) + +asDataDecl :: Decl v a -> DataDeclaration v a +asDataDecl = either toDataDecl id + +declDependencies :: Ord v => Decl v a -> Set Reference +declDependencies = either (dependencies . toDataDecl) dependencies + +constructorType :: Decl v a -> CT.ConstructorType +constructorType = \case + Left {} -> CT.Effect + Right {} -> CT.Data + +data Modifier = Structural | Unique Text -- | Opaque (Set Reference) + deriving (Eq, Ord, Show) + +data DataDeclaration v a = DataDeclaration + { modifier :: Modifier, + annotation :: a, + bound :: [v], + constructors' :: [(a, v, Type v a)] + } + deriving (Eq, Show, Functor) + +newtype EffectDeclaration v a = EffectDeclaration + { toDataDecl :: DataDeclaration v a + } + deriving (Eq, Show, Functor) + +constructorTypes :: DataDeclaration v a -> [Type v a] +constructorTypes = (snd <$>) . constructors + +constructors :: DataDeclaration v a -> [(v, Type v a)] +constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] + +-- -- This function is unsound, since the `rid` and the `decl` have to match. +-- -- It should probably be hashed directly from the Decl, once we have a +-- -- reliable way of doing that. —AI +-- declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] +-- declConstructorReferents rid decl = +-- [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] +-- where ct = constructorType decl + +-- constructorIds :: DataDeclaration v a -> [Int] +-- constructorIds dd = [0 .. length (constructors dd) - 1] + +dependencies :: Ord v => DataDeclaration v a -> Set Reference +dependencies dd = + Set.unions (Type.dependencies <$> constructorTypes dd) + +toABT :: Var v => DataDeclaration v () -> ABT.Term F v () +toABT dd = ABT.tm $ Modified (modifier dd) dd' + where + dd' = ABT.absChain (bound dd) $ ABT.cycle + (ABT.absChain + (fst <$> constructors dd) + (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) + +-- Implementation detail of `hashDecls`, works with unannotated data decls +hashDecls0 :: (Eq v, Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] +hashDecls0 decls = + let abts = toABT <$> decls + ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) + cs = Reference.Util.hashComponents ref abts + in [(v, r) | (v, (r, _)) <- Map.toList cs] + +-- | compute the hashes of these user defined types and update any free vars +-- corresponding to these decls with the resulting hashes +-- +-- data List a = Nil | Cons a (List a) +-- becomes something like +-- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) +-- +-- NOTE: technical limitation, this implementation gives diff results if ctors +-- have the same FQN as one of the types. TODO: assert this and bomb if not +-- satisfied, or else do local mangling and unmangling to ensure this doesn't +-- affect the hash. +hashDecls :: + (Eq v, Var v, Show v) => + Map v (DataDeclaration v a) -> + Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] +hashDecls decls = do + -- todo: make sure all other external references are resolved before calling this + let varToRef = hashDecls0 (void <$> decls) + varToRef' = second Reference.DerivedId <$> varToRef + decls' = bindTypes <$> decls + bindTypes dd = dd {constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd} + typeReferences = Map.fromList (first Name.fromVar <$> varToRef') + -- normalize the order of the constructors based on a hash of their types + sortCtors dd = dd {constructors' = sortOn hash3 $ constructors' dd} + hash3 (_, _, typ) = ABT.hash typ :: Hash + decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' + pure [(v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls']] + +bindReferences :: + Var v => + Set v -> + Map Name.Name Reference -> + DataDeclaration v a -> + Names.ResolutionResult v a (DataDeclaration v a) +bindReferences keepFree names (DataDeclaration m a bound constructors) = do + constructors <- for constructors $ \(a, v, ty) -> + (a,v,) <$> Type.bindReferences keepFree names ty + pure $ DataDeclaration m a bound constructors + +data F a + = Type (Type.F a) + | LetRec [a] a + | Constructors [a] + | Modified Modifier a + deriving (Functor, Foldable, Show, Show1) + +instance Hashable1 F where + hash1 hashCycle hash e = + let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + in -- Note: start each layer with leading `2` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + Hashable.accumulate $ + tag 2 : case e of + Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] + LetRec bindings body -> + let (hashes, hash') = hashCycle bindings + in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] + Constructors cs -> + let (hashes, _) = hashCycle cs + in tag 2 : map hashed hashes + Modified m t -> + [tag 3, Hashable.accumulateToken m, hashed $ hash t] + +instance Hashable.Hashable Modifier where + tokens Structural = [Hashable.Tag 0] + tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] diff --git a/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs new file mode 100644 index 0000000000..5bbdbe3730 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V2.LabeledDependency + ( derivedTerm + , derivedType + , termRef + , typeRef + , referent + , dataConstructor + , effectConstructor + , fold + , referents + , toReference + , LabeledDependency + , partition + ) where + +import Unison.Prelude hiding (fold) + +import qualified Data.Set as Set +import Unison.Hashing.V2.Reference (Id, Reference (DerivedId)) +import Unison.Hashing.V2.Referent (ConstructorId, Referent, pattern Con, pattern Ref) +import Unison.ConstructorType (ConstructorType (Data, Effect)) + +-- dumb constructor name is private +newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show) + +derivedType, derivedTerm :: Id -> LabeledDependency +typeRef, termRef :: Reference -> LabeledDependency +referent :: Referent -> LabeledDependency +dataConstructor :: Reference -> ConstructorId -> LabeledDependency +effectConstructor :: Reference -> ConstructorId -> LabeledDependency + +derivedType = X . Left . DerivedId +derivedTerm = X . Right . Ref . DerivedId +typeRef = X . Left +termRef = X . Right . Ref +referent = X . Right +dataConstructor r cid = X . Right $ Con r cid Data +effectConstructor r cid = X . Right $ Con r cid Effect + +referents :: Foldable f => f Referent -> Set LabeledDependency +referents rs = Set.fromList (map referent $ toList rs) + +fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a +fold f g (X e) = either f g e + +partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent]) +partition = partitionEithers . map (\(X e) -> e) . toList + +-- | Left TypeRef | Right TermRef +toReference :: LabeledDependency -> Either Reference Reference +toReference = \case + X (Left r) -> Left r + X (Right (Ref r)) -> Right r + X (Right (Con r _ _)) -> Left r \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs new file mode 100644 index 0000000000..6ced5fb8c5 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs @@ -0,0 +1,165 @@ +{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-} + +module Unison.Hashing.V2.Pattern where + +import Unison.Prelude + +import Data.Foldable as Foldable hiding (foldMap') +import Data.List (intercalate) +import qualified Data.Set as Set +-- import Unison.LabeledDependency (LabeledDependency) +-- import qualified Unison.LabeledDependency as LD +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.Hashable as H + +type ConstructorId = Int + +data Pattern loc + = Unbound loc + | Var loc + | Boolean loc !Bool + | Int loc !Int64 + | Nat loc !Word64 + | Float loc !Double + | Text loc !Text + | Char loc !Char + | Constructor loc !Reference !Int [Pattern loc] + | As loc (Pattern loc) + | EffectPure loc (Pattern loc) + | EffectBind loc !Reference !Int [Pattern loc] (Pattern loc) + | SequenceLiteral loc [Pattern loc] + | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + deriving (Ord,Generic,Functor,Foldable,Traversable) + +data SeqOp = Cons + | Snoc + | Concat + deriving (Eq, Show, Ord, Generic) + +instance H.Hashable SeqOp where + tokens Cons = [H.Tag 0] + tokens Snoc = [H.Tag 1] + tokens Concat = [H.Tag 2] + +instance Show (Pattern loc) where + show (Unbound _ ) = "Unbound" + show (Var _ ) = "Var" + show (Boolean _ x) = "Boolean " <> show x + show (Int _ x) = "Int " <> show x + show (Nat _ x) = "Nat " <> show x + show (Float _ x) = "Float " <> show x + show (Text _ t) = "Text " <> show t + show (Char _ c) = "Char " <> show c + show (Constructor _ r i ps) = + "Constructor " <> unwords [show r, show i, show ps] + show (As _ p) = "As " <> show p + show (EffectPure _ k) = "EffectPure " <> show k + show (EffectBind _ r i ps k) = + "EffectBind " <> unwords [show r, show i, show ps, show k] + show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) + show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt + +application :: Pattern loc -> Bool +application (Constructor _ _ _ (_ : _)) = True +application _ = False + +loc :: Pattern loc -> loc +loc p = head $ Foldable.toList p + +setLoc :: Pattern loc -> loc -> Pattern loc +setLoc p loc = case p of + EffectBind _ a b c d -> EffectBind loc a b c d + EffectPure _ a -> EffectPure loc a + As _ a -> As loc a + Constructor _ a b c -> Constructor loc a b c + SequenceLiteral _ ps -> SequenceLiteral loc ps + SequenceOp _ ph op pt -> SequenceOp loc ph op pt + x -> fmap (const loc) x + +instance H.Hashable (Pattern p) where + tokens (Unbound _) = [H.Tag 0] + tokens (Var _) = [H.Tag 1] + tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0] + tokens (Int _ n) = H.Tag 3 : [H.Int n] + tokens (Nat _ n) = H.Tag 4 : [H.Nat n] + tokens (Float _ f) = H.Tag 5 : H.tokens f + tokens (Constructor _ r n args) = + [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args] + tokens (EffectPure _ p) = H.Tag 7 : H.tokens p + tokens (EffectBind _ r n args k) = + [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k] + tokens (As _ p) = H.Tag 9 : H.tokens p + tokens (Text _ t) = H.Tag 10 : H.tokens t + tokens (SequenceLiteral _ ps) = H.Tag 11 : concatMap H.tokens ps + tokens (SequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r + tokens (Char _ c) = H.Tag 13 : H.tokens c + +instance Eq (Pattern loc) where + Unbound _ == Unbound _ = True + Var _ == Var _ = True + Boolean _ b == Boolean _ b2 = b == b2 + Int _ n == Int _ m = n == m + Nat _ n == Nat _ m = n == m + Float _ f == Float _ g = f == g + Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs + EffectPure _ p == EffectPure _ q = p == q + EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 + As _ p == As _ q = p == q + Text _ t == Text _ t2 = t == t2 + SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2 + SequenceOp _ ph op pt == SequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 + _ == _ = False + +foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m +foldMap' f p = case p of + Unbound _ -> f p + Var _ -> f p + Boolean _ _ -> f p + Int _ _ -> f p + Nat _ _ -> f p + Float _ _ -> f p + Text _ _ -> f p + Char _ _ -> f p + Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps + As _ p' -> f p <> foldMap' f p' + EffectPure _ p' -> f p <> foldMap' f p' + EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' + SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps + SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2 + +generalizedDependencies + :: Ord r + => (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Pattern loc + -> Set r +generalizedDependencies literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . foldMap' + (\case + Unbound _ -> mempty + Var _ -> mempty + As _ _ -> mempty + Constructor _ r cid _ -> [dataType r, dataConstructor r cid] + EffectPure _ _ -> [effectType Type.effectRef] + EffectBind _ r cid _ _ -> + [effectType Type.effectRef, effectType r, effectConstructor r cid] + SequenceLiteral _ _ -> [literalType Type.listRef] + SequenceOp {} -> [literalType Type.listRef] + Boolean _ _ -> [literalType Type.booleanRef] + Int _ _ -> [literalType Type.intRef] + Nat _ _ -> [literalType Type.natRef] + Float _ _ -> [literalType Type.floatRef] + Text _ _ -> [literalType Type.textRef] + Char _ _ -> [literalType Type.charRef] + ) + +-- labeledDependencies :: Pattern loc -> Set LabeledDependency +-- labeledDependencies = generalizedDependencies LD.typeRef +-- LD.dataConstructor +-- LD.typeRef +-- LD.effectConstructor +-- LD.typeRef \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs new file mode 100644 index 0000000000..b1ff2cf99c --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Reference + (Reference, + pattern Builtin, + pattern Derived, + pattern DerivedId, + Id(..), + Pos, + Size, + derivedBase32Hex, + Component, members, + components, + groupByComponent, + componentFor, + unsafeFromText, + idFromText, + isPrefixOf, + fromShortHash, + fromText, + readSuffix, + showShort, + showSuffix, + toId, + toText, + unsafeId, + toShortHash, + idToShortHash) where + +import Unison.Prelude + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Unison.Hash as H +import Unison.Hashable as Hashable +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import Data.Char (isDigit) + +-- | Either a builtin or a user defined (hashed) top-level declaration. +-- +-- Used for both terms and types. Doesn't distinguish between them. +-- +-- Other used defined things like local variables don't get @Reference@s. +data Reference + = Builtin Text.Text + -- `Derived` can be part of a strongly connected component. + -- The `Pos` refers to a particular element of the component + -- and the `Size` is the number of elements in the component. + -- Using an ugly name so no one tempted to use this + | DerivedId Id deriving (Eq,Ord,Generic) + +pattern Derived :: H.Hash -> Pos -> Size -> Reference +pattern Derived h i n = DerivedId (Id h i n) + +{-# COMPLETE Builtin, Derived #-} + +-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together. +data Id = Id H.Hash Pos Size deriving (Generic) + +unsafeId :: Reference -> Id +unsafeId (Builtin b) = + error $ "Tried to get the hash of builtin " <> Text.unpack b <> "." +unsafeId (DerivedId x) = x + +idToShortHash :: Id -> ShortHash +idToShortHash = toShortHash . DerivedId + +-- todo: move these to ShortHash module? +-- but Show Reference currently depends on SH +toShortHash :: Reference -> ShortHash +toShortHash (Builtin b) = SH.Builtin b +toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing +toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing + where + -- todo: remove `n` parameter; must also update readSuffix + index = Just $ showSuffix i n + +-- toShortHash . fromJust . fromShortHash == id and +-- fromJust . fromShortHash . toShortHash == id +-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it +-- may not be possible to base32Hex decode them. These will return Nothing. +-- Also, ShortHashes that include constructor ids will return Nothing; +-- try Referent.fromShortHash +fromShortHash :: ShortHash -> Maybe Reference +fromShortHash (SH.Builtin b) = Just (Builtin b) +fromShortHash (SH.ShortHash prefix cycle Nothing) = do + h <- H.fromBase32Hex prefix + case cycle of + Nothing -> Just (Derived h 0 1) + Just t -> case Text.splitOn "c" t of + [i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n) + _ -> Nothing +fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing + +-- (3,10) encoded as "3c10" +-- (0,93) encoded as "0c93" +showSuffix :: Pos -> Size -> Text +showSuffix i n = Text.pack $ show i <> "c" <> show n + +-- todo: don't read or return size; must also update showSuffix and fromText +readSuffix :: Text -> Either String (Pos, Size) +readSuffix t = case Text.breakOn "c" t of + (pos, Text.drop 1 -> size) | Text.all isDigit pos && Text.all isDigit size -> + Right (read (Text.unpack pos), read (Text.unpack size)) + _ -> Left "suffix decoding error" + +isPrefixOf :: ShortHash -> Reference -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +toText :: Reference -> Text +toText = SH.toText . toShortHash + +showShort :: Int -> Reference -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +type Pos = Word64 +type Size = Word64 + +newtype Component = Component { members :: Set Reference } + +-- Gives the component (dependency cycle) that the reference is a part of +componentFor :: Reference -> Component +componentFor b@Builtin {} = Component (Set.singleton b) +componentFor (Derived h _ n) = + Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]] + +derivedBase32Hex :: Text -> Pos -> Size -> Reference +derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n) + where + msg = error $ "Reference.derivedBase32Hex " <> show h + h = H.fromBase32Hex b32Hex + +unsafeFromText :: Text -> Reference +unsafeFromText = either error id . fromText + +idFromText :: Text -> Maybe Id +idFromText s = case fromText s of + Left _ -> Nothing + Right (Builtin _) -> Nothing + Right (DerivedId id) -> pure id + +toId :: Reference -> Maybe Id +toId (DerivedId id) = Just id +toId Builtin{} = Nothing + +-- examples: +-- `##Text.take` — builtins don’t have cycles +-- `#2tWjVAuc7` — derived, no cycle +-- `#y9ycWkiC1.y9` — derived, part of cycle +-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text. +fromText :: Text -> Either String Reference +fromText t = case Text.split (=='#') t of + [_, "", b] -> Right (Builtin b) + [_, h] -> case Text.split (=='.') h of + [hash] -> Right (derivedBase32Hex hash 0 1) + [hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix + _ -> bail + _ -> bail + where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t + +component :: H.Hash -> [k] -> [(k, Id)] +component h ks = let + size = fromIntegral (length ks) + in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]] + +components :: [(H.Hash, [k])] -> [(k, Id)] +components sccs = uncurry component =<< sccs + +groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] +groupByComponent refs = done $ foldl' insert Map.empty refs + where + insert m (k, r@(Derived h _ _)) = + Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])]) + insert m (k, r) = + Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])]) + done m = sortOn snd <$> toList m + +instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId +instance Show Reference where show = SH.toString . SH.take 5 . toShortHash + +instance Hashable.Hashable Reference where + tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt] + tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toBytes h), Hashable.Nat i, Hashable.Nat n] + +-- | Two references mustn't differ in cycle length only. +instance Eq Id where x == y = compare x y == EQ +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs new file mode 100644 index 0000000000..77b02efb5c --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs @@ -0,0 +1,21 @@ +module Unison.Hashing.V2.Reference.Util where + +import Unison.Prelude + +import qualified Unison.Hashing.V2.Reference as Reference +import Unison.Hashable (Hashable1) +import Unison.ABT (Var) +import qualified Unison.ABT as ABT +import qualified Data.Map as Map + +hashComponents :: + (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) + => (Reference.Id -> ABT.Term f v ()) + -> Map v (ABT.Term f v a) + -> Map v (Reference.Id, ABT.Term f v a) +hashComponents embedRef tms = + Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] + where cs = Reference.components $ ABT.hashComponents ref tms + ref h i n = embedRef (Reference.Id h i n) + + diff --git a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs new file mode 100644 index 0000000000..04531bcaff --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Unison.Hashing.V2.Referent where + +import Unison.Prelude +import Unison.Referent' ( Referent'(..), toReference' ) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as R +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH + +import Unison.ConstructorType (ConstructorType) +import qualified Unison.ConstructorType as CT + +-- | Specifies a term. +-- +-- Either a term 'Reference', a data constructor, or an effect constructor. +-- +-- Slightly odd naming. This is the "referent of term name in the codebase", +-- rather than the target of a Reference. +type Referent = Referent' Reference +type ConstructorId = Int +pattern Ref :: Reference -> Referent +pattern Ref r = Ref' r +pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent +pattern Con r i t = Con' r i t +{-# COMPLETE Ref, Con #-} + +-- | Cannot be a builtin. +type Id = Referent' R.Id + +-- referentToTerm moved to Term.fromReferent +-- termToReferent moved to Term.toReferent + +-- todo: move these to ShortHash module +toShortHash :: Referent -> ShortHash +toShortHash = \case + Ref r -> R.toShortHash r + Con r i _ -> patternShortHash r i + +toShortHashId :: Id -> ShortHash +toShortHashId = toShortHash . fromId + +-- also used by HashQualified.fromPattern +patternShortHash :: Reference -> ConstructorId -> ShortHash +patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i } + +showShort :: Int -> Referent -> Text +showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash + +toText :: Referent -> Text +toText = \case + Ref r -> R.toText r + Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid) + +ctorTypeText :: CT.ConstructorType -> Text +ctorTypeText CT.Effect = EffectCtor +ctorTypeText CT.Data = DataCtor + +pattern EffectCtor = "a" +pattern DataCtor = "d" + +toString :: Referent -> String +toString = Text.unpack . toText + +isConstructor :: Referent -> Bool +isConstructor Con{} = True +isConstructor _ = False + +toTermReference :: Referent -> Maybe Reference +toTermReference = \case + Ref r -> Just r + _ -> Nothing + +toReference :: Referent -> Reference +toReference = toReference' + +fromId :: Id -> Referent +fromId = fmap R.DerivedId + +toTypeReference :: Referent -> Maybe Reference +toTypeReference = \case + Con r _i _t -> Just r + _ -> Nothing + +isPrefixOf :: ShortHash -> Referent -> Bool +isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r) + +unsafeFromText :: Text -> Referent +unsafeFromText = fromMaybe (error "invalid referent") . fromText + +-- #abc[.xy][#cid] +fromText :: Text -> Maybe Referent +fromText t = either (const Nothing) Just $ + -- if the string has just one hash at the start, it's just a reference + if Text.length refPart == 1 then + Ref <$> R.fromText t + else if Text.all Char.isDigit cidPart then do + r <- R.fromText (Text.dropEnd 1 refPart) + ctorType <- ctorType + let cid = read (Text.unpack cidPart) + pure $ Con r cid ctorType + else + Left ("invalid constructor id: " <> Text.unpack cidPart) + where + ctorType = case Text.take 1 cidPart' of + EffectCtor -> Right CT.Effect + DataCtor -> Right CT.Data + _otherwise -> + Left ("invalid constructor type (expected '" + <> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart') + refPart = Text.dropWhileEnd (/= '#') t + cidPart' = Text.takeWhileEnd (/= '#') t + cidPart = Text.drop 1 cidPart' + +fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a +fold fr fc = \case + Ref' r -> fr r + Con' r i ct -> fc r i ct diff --git a/parser-typechecker/src/Unison/Hashing/V2/Term.hs b/parser-typechecker/src/Unison/Hashing/V2/Term.hs new file mode 100644 index 0000000000..4d0eeb907a --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Term.hs @@ -0,0 +1,1120 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Term where + +import Unison.Prelude + +import Prelude hiding (and,or) +import Control.Monad.State (evalState) +import qualified Control.Monad.Writer.Strict as Writer +import Data.Bifunctor (second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Sequence as Sequence +import Prelude.Extras (Eq1(..), Show1(..)) +import Text.Show +import qualified Unison.ABT as ABT +import qualified Unison.Blank as B +import qualified Unison.Hash as Hash +import Unison.Hashable (Hashable1, accumulateToken) +import qualified Unison.Hashable as Hashable +import Unison.Hashing.V2.Pattern (Pattern) +import qualified Unison.Hashing.V2.Pattern as Pattern +import Unison.Hashing.V2.Reference (Reference, pattern Builtin) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil +import Unison.Hashing.V2.Referent (Referent) +import qualified Unison.Hashing.V2.Referent as Referent +import Unison.Hashing.V2.Type (Type) +import qualified Unison.Hashing.V2.Type as Type +import qualified Unison.ConstructorType as CT +import Unison.Util.List (multimap) +import Unison.Var (Var) +import qualified Unison.Var as Var +import Unsafe.Coerce +import Unison.Symbol (Symbol) +import qualified Unison.Hashing.V2.LabeledDependency as LD +import Unison.Hashing.V2.LabeledDependency (LabeledDependency) + +-- This gets reexported; should maybe live somewhere other than Pattern, though. +type ConstructorId = Pattern.ConstructorId + +data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a + deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable) + +-- | Base functor for terms in the Unison language +-- We need `typeVar` because the term and type variables may differ. +data F typeVar typeAnn patternAnn a + = Int Int64 + | Nat Word64 + | Float Double + | Boolean Bool + | Text Text + | Char Char + | Blank (B.Blank typeAnn) + | Ref Reference + -- First argument identifies the data type, + -- second argument identifies the constructor + | Constructor Reference ConstructorId + | Request Reference ConstructorId + | Handle a a + | App a a + | Ann a (Type typeVar typeAnn) + | List (Seq a) + | If a a a + | And a a + | Or a a + | Lam a + -- Note: let rec blocks have an outer ABT.Cycle which introduces as many + -- variables as there are bindings + | LetRec IsTop [a] a + -- Note: first parameter is the binding, second is the expression which may refer + -- to this let bound variable. Constructed as `Let b (abs v e)` + | Let IsTop a a + -- Pattern matching / eliminating data types, example: + -- case x of + -- Just n -> rhs1 + -- Nothing -> rhs2 + -- + -- translates to + -- + -- Match x + -- [ (Constructor 0 [Var], ABT.abs n rhs1) + -- , (Constructor 1 [], rhs2) ] + | Match a [MatchCase patternAnn a] + | TermLink Referent + | TypeLink Reference + deriving (Foldable,Functor,Generic,Generic1,Traversable) + +type IsTop = Bool + +-- | Like `Term v`, but with an annotation of type `a` at every level in the tree +type Term v a = Term2 v a a v a +-- | Allow type variables and term variables to differ +type Term' vt v a = Term2 vt a a v a +-- | Allow type variables, term variables, type annotations and term annotations +-- to all differ +type Term2 vt at ap v a = ABT.Term (F vt at ap) v a +-- | Like `Term v a`, but with only () for type and pattern annotations. +type Term3 v a = Term2 v () () v a + +-- | Terms are represented as ABTs over the base functor F, with variables in `v` +type Term0 v = Term v () +-- | Terms with type variables in `vt`, and term variables in `v` +type Term0' vt v = Term' vt v () + +-- Prepare a term for type-directed name resolution by replacing +-- any remaining free variables with blanks to be resolved by TDNR +prepareTDNR :: Var v => ABT.Term (F vt b ap) v b -> ABT.Term (F vt b ap) v b +prepareTDNR t = fmap fst . ABT.visitPure f $ ABT.annotateBound t + where f (ABT.Term _ (a, bound) (ABT.Var v)) | Set.notMember v bound = + Just $ resolve (a, bound) a (Text.unpack $ Var.name v) + f _ = Nothing + +amap :: Ord v => (a -> a2) -> Term v a -> Term v a2 +amap f = fmap f . patternMap (fmap f) . typeMap (fmap f) + +patternMap :: (Pattern ap -> Pattern ap2) -> Term2 vt at ap v a -> Term2 vt at ap2 v a +patternMap f = go where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Match e cases) -> ABT.Tm (Match (go e) [ + MatchCase (f p) (go <$> g) (go a) | MatchCase p g a <- cases ]) + -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +vmap :: Ord v2 => (v -> v2) -> Term v a -> Term v2 a +vmap f = ABT.vmap f . typeMap (ABT.vmap f) + +vtmap :: Ord vt2 => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a +vtmap f = typeMap (ABT.vmap f) + +typeMap + :: Ord vt2 + => (Type vt at -> Type vt2 at2) + -> Term2 vt at ap v a + -> Term2 vt2 at2 ap v a +typeMap f = go + where + go (ABT.Term fvs a t) = ABT.Term fvs a $ case t of + ABT.Abs v t -> ABT.Abs v (go t) + ABT.Var v -> ABT.Var v + ABT.Cycle t -> ABT.Cycle (go t) + ABT.Tm (Ann e t) -> ABT.Tm (Ann (go e) (f t)) + -- Safe since `Ann` is only ctor that has embedded `Type v` arg + -- otherwise we'd have to manually match on every non-`Ann` ctor + ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) + +extraMap' + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> Term2 vt at ap v a + -> Term2 vt' at' ap' v a +extraMap' vtf atf apf = ABT.extraMap (extraMap vtf atf apf) + +extraMap + :: (Ord vt, Ord vt') + => (vt -> vt') + -> (at -> at') + -> (ap -> ap') + -> F vt at ap a + -> F vt' at' ap' a +extraMap vtf atf apf = \case + Int x -> Int x + Nat x -> Nat x + Float x -> Float x + Boolean x -> Boolean x + Text x -> Text x + Char x -> Char x + Blank x -> Blank (fmap atf x) + Ref x -> Ref x + Constructor x y -> Constructor x y + Request x y -> Request x y + Handle x y -> Handle x y + App x y -> App x y + Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x)) + List x -> List x + If x y z -> If x y z + And x y -> And x y + Or x y -> Or x y + Lam x -> Lam x + LetRec x y z -> LetRec x y z + Let x y z -> Let x y z + Match tm l -> Match tm (map (matchCaseExtraMap apf) l) + TermLink r -> TermLink r + TypeLink r -> TypeLink r + +matchCaseExtraMap :: (loc -> loc') -> MatchCase loc a -> MatchCase loc' a +matchCaseExtraMap f (MatchCase p x y) = MatchCase (fmap f p) x y + +unannotate + :: forall vt at ap v a . Ord v => Term2 vt at ap v a -> Term0' vt v +unannotate = go + where + go :: Term2 vt at ap v a -> Term0' vt v + go (ABT.out -> ABT.Abs v body) = ABT.abs v (go body) + go (ABT.out -> ABT.Cycle body) = ABT.cycle (go body) + go (ABT.Var' v ) = ABT.var v + go (ABT.Tm' f ) = case go <$> f of + Ann e t -> ABT.tm (Ann e (void t)) + Match scrutinee branches -> + let unann (MatchCase pat guard body) = MatchCase (void pat) guard body + in ABT.tm (Match scrutinee (unann <$> branches)) + f' -> ABT.tm (unsafeCoerce f') + go _ = error "unpossible" + +wrapV :: Ord v => Term v a -> Term (ABT.V v) a +wrapV = vmap ABT.Bound + +-- | All variables mentioned in the given term. +-- Includes both term and type variables, both free and bound. +allVars :: Ord v => Term v a -> Set v +allVars tm = Set.fromList $ + ABT.allVars tm ++ [ v | tp <- allTypes tm, v <- ABT.allVars tp ] + where + allTypes tm = case tm of + Ann' e tp -> tp : allTypes e + _ -> foldMap allTypes $ ABT.out tm + +freeVars :: Term' vt v a -> Set v +freeVars = ABT.freeVars + +freeTypeVars :: Ord vt => Term' vt v a -> Set vt +freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t + +freeTypeVarAnnotations :: Ord vt => Term' vt v a -> Map vt [a] +freeTypeVarAnnotations e = multimap $ go Set.empty e where + go bound tm = case tm of + Var' _ -> mempty + Ann' e (Type.stripIntroOuters -> t1) -> let + bound' = case t1 of Type.ForallsNamed' vs _ -> bound <> Set.fromList vs + _ -> bound + in go bound' e <> ABT.freeVarOccurrences bound t1 + ABT.Tm' f -> foldMap (go bound) f + (ABT.out -> ABT.Abs _ body) -> go bound body + (ABT.out -> ABT.Cycle body) -> go bound body + _ -> error "unpossible" + +substTypeVars :: (Ord v, Var vt) + => [(vt, Type vt b)] + -> Term' vt v a + -> Term' vt v a +substTypeVars subs e = foldl' go e subs where + go e (vt, t) = substTypeVar vt t e + +-- Capture-avoiding substitution of a type variable inside a term. This +-- will replace that type variable wherever it appears in type signatures of +-- the term, avoiding capture by renaming ∀-binders. +substTypeVar + :: (Ord v, ABT.Var vt) + => vt + -> Type vt b + -> Term' vt v a + -> Term' vt v a +substTypeVar vt ty = go Set.empty where + go bound tm | Set.member vt bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> uncapture [] e (Type.stripIntroOuters t) where + fvs = ABT.freeVars ty + -- if the ∀ introduces a variable, v, which is free in `ty`, we pick a new + -- variable name for v which is unique, v', and rename v to v' in e. + uncapture vs e t@(Type.Forall' body) | Set.member (ABT.variable body) fvs = let + v = ABT.variable body + v2 = Var.freshIn (ABT.freeVars t) . Var.freshIn (Set.insert vt fvs) $ v + t2 = ABT.bindInheritAnnotation body (Type.var() v2) + in uncapture ((ABT.annotation t, v2):vs) (renameTypeVar v v2 e) t2 + uncapture vs e t0 = let + t = foldl (\body (loc,v) -> Type.forall loc v body) t0 vs + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.substInheritAnnotation vt ty (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +renameTypeVar :: (Ord v, ABT.Var vt) => vt -> vt -> Term' vt v a -> Term' vt v a +renameTypeVar old new = go Set.empty where + go bound tm | Set.member old bound = tm + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e t -> let + bound' = case Type.unForalls (Type.stripIntroOuters t) of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + t' = ABT.rename old new (Type.stripIntroOuters t) + in ann loc (go bound' e) (Type.freeVarsToOuters bound t') + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- Converts free variables to bound variables using forall or introOuter. Example: +-- +-- foo : x -> x +-- foo a = +-- r : x +-- r = a +-- r +-- +-- This becomes: +-- +-- foo : ∀ x . x -> x +-- foo a = +-- r : outer x . x -- FYI, not valid syntax +-- r = a +-- r +-- +-- More specifically: in the expression `e : t`, unbound lowercase variables in `t` +-- are bound with foralls, and any ∀-quantified type variables are made bound in +-- `e` and its subexpressions. The result is a term with no lowercase free +-- variables in any of its type signatures, with outer references represented +-- with explicit `introOuter` binders. The resulting term may have uppercase +-- free variables that are still unbound. +generalizeTypeSignatures :: (Var vt, Var v) => Term' vt v a -> Term' vt v a +generalizeTypeSignatures = go Set.empty where + go bound tm = let loc = ABT.annotation tm in case tm of + Var' _ -> tm + Ann' e (Type.generalizeLowercase bound -> t) -> let + bound' = case Type.unForalls t of + Nothing -> bound + Just (vs, _) -> bound <> Set.fromList vs + in ann loc (go bound' e) (Type.freeVarsToOuters bound t) + ABT.Tm' f -> ABT.tm' loc (go bound <$> f) + (ABT.out -> ABT.Abs v body) -> ABT.abs' loc v (go bound body) + (ABT.out -> ABT.Cycle body) -> ABT.cycle' loc (go bound body) + _ -> error "unpossible" + +-- nicer pattern syntax + +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst +pattern Int' n <- (ABT.out -> ABT.Tm (Int n)) +pattern Nat' n <- (ABT.out -> ABT.Tm (Nat n)) +pattern Float' n <- (ABT.out -> ABT.Tm (Float n)) +pattern Boolean' b <- (ABT.out -> ABT.Tm (Boolean b)) +pattern Text' s <- (ABT.out -> ABT.Tm (Text s)) +pattern Char' c <- (ABT.out -> ABT.Tm (Char c)) +pattern Blank' b <- (ABT.out -> ABT.Tm (Blank b)) +pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r)) +pattern TermLink' r <- (ABT.out -> ABT.Tm (TermLink r)) +pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r)) +pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r))) +pattern App' f x <- (ABT.out -> ABT.Tm (App f x)) +pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches)) +pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n)) +pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n)) +pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n)) +pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f)) +pattern And' x y <- (ABT.out -> ABT.Tm (And x y)) +pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y)) +pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) +pattern Apps' f args <- (unApps -> Just (f, args)) +-- begin pretty-printer helper patterns +pattern AppsPred' f args <- (unAppsPred -> Just (f, args)) +pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) +pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) +pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) +-- end pretty-printer helper patterns +pattern Ann' x t <- (ABT.out -> ABT.Tm (Ann x t)) +pattern List' xs <- (ABT.out -> ABT.Tm (List xs)) +pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst)) + +pattern Delay' body <- (unDelay -> Just body) +unDelay :: Ord v => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a) +unDelay tm = case ABT.out tm of + ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))) + | Set.notMember v (ABT.freeVars body) + -> Just body + _ -> Nothing + +pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) +pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) +pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) +pattern LamsNamedPred' vs body <- (unLamsPred' -> Just (vs, body)) +pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body)) +pattern Let1' b subst <- (unLet1 -> Just (_, b, subst)) +pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst)) +pattern Let1Named' v b e <- (ABT.Tm' (Let _ b (ABT.out -> ABT.Abs v e))) +pattern Let1NamedTop' top v b e <- (ABT.Tm' (Let top b (ABT.out -> ABT.Abs v e))) +pattern Lets' bs e <- (unLet -> Just (bs, e)) +pattern LetRecNamed' bs e <- (unLetRecNamed -> Just (_,bs,e)) +pattern LetRecNamedTop' top bs e <- (unLetRecNamed -> Just (top,bs,e)) +pattern LetRec' subst <- (unLetRec -> Just (_, subst)) +pattern LetRecTop' top subst <- (unLetRec -> Just (top, subst)) +pattern LetRecNamedAnnotated' ann bs e <- (unLetRecNamedAnnotated -> Just (_, ann, bs,e)) +pattern LetRecNamedAnnotatedTop' top ann bs e <- + (unLetRecNamedAnnotated -> Just (top, ann, bs,e)) + +fresh :: Var v => Term0 v -> v -> v +fresh = ABT.fresh + +-- some smart constructors + +var :: a -> v -> Term2 vt at ap v a +var = ABT.annotatedVar + +var' :: Var v => Text -> Term0' vt v +var' = var() . Var.named + +ref :: Ord v => a -> Reference -> Term2 vt at ap v a +ref a r = ABT.tm' a (Ref r) + +pattern Referent' r <- (unReferent -> Just r) + +unReferent :: Term2 vt at ap v a -> Maybe Referent +unReferent (Ref' r) = Just $ Referent.Ref r +unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data +unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect +unReferent _ = Nothing + +refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Referent -> Term2 vt at ap v a +termLink a r = ABT.tm' a (TermLink r) + +typeLink :: Ord v => a -> Reference -> Term2 vt at ap v a +typeLink a r = ABT.tm' a (TypeLink r) + +builtin :: Ord v => a -> Text -> Term2 vt at ap v a +builtin a n = ref a (Reference.Builtin n) + +float :: Ord v => a -> Double -> Term2 vt at ap v a +float a d = ABT.tm' a (Float d) + +boolean :: Ord v => a -> Bool -> Term2 vt at ap v a +boolean a b = ABT.tm' a (Boolean b) + +int :: Ord v => a -> Int64 -> Term2 vt at ap v a +int a d = ABT.tm' a (Int d) + +nat :: Ord v => a -> Word64 -> Term2 vt at ap v a +nat a d = ABT.tm' a (Nat d) + +text :: Ord v => a -> Text -> Term2 vt at ap v a +text a = ABT.tm' a . Text + +char :: Ord v => a -> Char -> Term2 vt at ap v a +char a = ABT.tm' a . Char + +watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a +watch a note e = + apps' (builtin a "Debug.watch") [text a (Text.pack note), e] + +watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a +watchMaybe Nothing e = e +watchMaybe (Just note) e = watch (ABT.annotation e) note e + +blank :: Ord v => a -> Term2 vt at ap v a +blank a = ABT.tm' a (Blank B.Blank) + +placeholder :: Ord v => a -> String -> Term2 vt a ap v a +placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) + +resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at +resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) + +constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +constructor a ref n = ABT.tm' a (Constructor ref n) + +request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a +request a ref n = ABT.tm' a (Request ref n) + +-- todo: delete and rename app' to app +app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v +app_ f arg = ABT.tm (App f arg) + +app :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +app a f arg = ABT.tm' a (App f arg) + +match :: Ord v => a -> Term2 vt at a v a -> [MatchCase a (Term2 vt at a v a)] -> Term2 vt at a v a +match a scrutinee branches = ABT.tm' a (Match scrutinee branches) + +handle :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +handle a h block = ABT.tm' a (Handle h block) + +and :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +and a x y = ABT.tm' a (And x y) + +or :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +or a x y = ABT.tm' a (Or x y) + +list :: Ord v => a -> [Term2 vt at ap v a] -> Term2 vt at ap v a +list a es = list' a (Sequence.fromList es) + +list' :: Ord v => a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a +list' a es = ABT.tm' a (List es) + +apps + :: Ord v + => Term2 vt at ap v a + -> [(a, Term2 vt at ap v a)] + -> Term2 vt at ap v a +apps = foldl' (\f (a, t) -> app a f t) + +apps' + :: (Ord v, Semigroup a) + => Term2 vt at ap v a + -> [Term2 vt at ap v a] + -> Term2 vt at ap v a +apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) + +iff :: Ord v => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a +iff a cond t f = ABT.tm' a (If cond t f) + +ann_ :: Ord v => Term0' vt v -> Type vt () -> Term0' vt v +ann_ e t = ABT.tm (Ann e t) + +ann :: Ord v + => a + -> Term2 vt at ap v a + -> Type vt at + -> Term2 vt at ap v a +ann a e t = ABT.tm' a (Ann e t) + +-- arya: are we sure we want the two annotations to be the same? +lam :: Ord v => a -> v -> Term2 vt at ap v a -> Term2 vt at ap v a +lam a v body = ABT.tm' a (Lam (ABT.abs' a v body)) + +delay :: Var v => a -> Term2 vt at ap v a -> Term2 vt at ap v a +delay a body = + ABT.tm' a (Lam (ABT.abs' a (ABT.freshIn (ABT.freeVars body) (Var.named "_")) body)) + +lam' :: Ord v => a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam' a vs body = foldr (lam a) body vs + +lam'' :: Ord v => [(a,v)] -> Term2 vt at ap v a -> Term2 vt at ap v a +lam'' vs body = foldr (uncurry lam) body vs + +isLam :: Term2 vt at ap v a -> Bool +isLam t = arity t > 0 + +arity :: Term2 vt at ap v a -> Int +arity (LamNamed' _ body) = 1 + arity body +arity (Ann' e _) = arity e +arity _ = 0 + +unLetRecNamedAnnotated + :: Term' vt v a + -> Maybe + (IsTop, a, [((a, v), Term' vt v a)], Term' vt v a) +unLetRecNamedAnnotated (ABT.CycleA' ann avs (ABT.Tm' (LetRec isTop bs e))) = + Just (isTop, ann, avs `zip` bs, e) +unLetRecNamedAnnotated _ = Nothing + +letRec' + :: (Ord v, Monoid a) + => Bool + -> [(v, Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec' isTop bindings body = + letRec isTop + (foldMap (ABT.annotation . snd) bindings <> ABT.annotation body) + [ ((ABT.annotation b, v), b) | (v,b) <- bindings ] + body + +-- Prepend a binding to form a (bigger) let rec. Useful when +-- building up a block incrementally using a right fold. +-- +-- For example: +-- consLetRec (x = 42) "hi" +-- => +-- let rec x = 42 in "hi" +-- +-- consLetRec (x = 42) (let rec y = "hi" in (x,y)) +-- => +-- let rec x = 42; y = "hi" in (x,y) +consLetRec + :: Ord v + => Bool -- isTop parameter + -> a -- annotation for overall let rec + -> (a, v, Term' vt v a) -- the binding + -> Term' vt v a -- the body + -> Term' vt v a +consLetRec isTop a (ab, vb, b) body = case body of + LetRecNamedAnnotated' _ bs body -> letRec isTop a (((ab,vb), b) : bs) body + _ -> letRec isTop a [((ab,vb),b)] body + +letRec + :: Ord v + => Bool + -> a + -> [((a, v), Term' vt v a)] + -> Term' vt v a + -> Term' vt v a +letRec _ _ [] e = e +letRec isTop a bindings e = ABT.cycle' + a + (foldr (uncurry ABT.abs' . fst) z bindings) + where z = ABT.tm' a (LetRec isTop (map snd bindings) e) + + +-- | Smart constructor for let rec blocks. Each binding in the block may +-- reference any other binding in the block in its body (including itself), +-- and the output expression may also reference any binding in the block. +letRec_ :: Ord v => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v +letRec_ _ [] e = e +letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) + where + z = ABT.tm (LetRec isTop (map snd bindings) e) + +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. +-- todo: delete me +let1_ :: Ord v => IsTop -> [(v,Term0' vt v)] -> Term0' vt v -> Term0' vt v +let1_ isTop bindings e = foldr f e bindings + where + f (v,b) body = ABT.tm (Let isTop b (ABT.abs v body)) + +-- | annotations are applied to each nested Let expression +let1 + :: Ord v + => IsTop + -> [((a, v), Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1 isTop bindings e = foldr f e bindings + where f ((ann, v), b) body = ABT.tm' ann (Let isTop b (ABT.abs' ann v body)) + +let1' + :: (Semigroup a, Ord v) + => IsTop + -> [(v, Term2 vt at ap v a)] + -> Term2 vt at ap v a + -> Term2 vt at ap v a +let1' isTop bindings e = foldr f e bindings + where + ann = ABT.annotation + f (v, b) body = ABT.tm' a (Let isTop b (ABT.abs' a v body)) + where a = ann b <> ann body + +-- let1' :: Var v => [(Text, Term0 vt v)] -> Term0 vt v -> Term0 vt v +-- let1' bs e = let1 [(ABT.v' name, b) | (name,b) <- bs ] e + +unLet1 + :: Var v + => Term' vt v a + -> Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a) +unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst) +unLet1 _ = Nothing + +-- | Satisfies `unLet (let' bs e) == Just (bs, e)` +unLet + :: Term2 vt at ap v a + -> Maybe ([(IsTop, v, Term2 vt at ap v a)], Term2 vt at ap v a) +unLet t = fixup (go t) + where + go (ABT.Tm' (Let isTop b (ABT.out -> ABT.Abs v t))) = case go t of + (env, t) -> ((isTop, v, b) : env, t) + go t = ([], t) + fixup ([], _) = Nothing + fixup bst = Just bst + +-- | Satisfies `unLetRec (letRec bs e) == Just (bs, e)` +unLetRecNamed + :: Term2 vt at ap v a + -> Maybe + ( IsTop + , [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unLetRecNamed (ABT.Cycle' vs (ABT.Tm' (LetRec isTop bs e))) + | length vs == length bs = Just (isTop, zip vs bs, e) +unLetRecNamed _ = Nothing + +unLetRec + :: (Monad m, Var v) + => Term2 vt at ap v a + -> Maybe + ( IsTop + , (v -> m v) + -> m + ( [(v, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) + ) +unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = Just + ( isTop + , \freshen -> do + vs <- sequence [ freshen v | (v, _) <- bs ] + let sub = ABT.substsInheritAnnotation (map fst bs `zip` map ABT.var vs) + pure (vs `zip` [ sub b | (_, b) <- bs ], sub e) + ) +unLetRec _ = Nothing + +unApps + :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unApps t = unAppsPred (t, const True) + +-- Same as unApps but taking a predicate controlling whether we match on a given function argument. +unAppsPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> + Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) +unAppsPred (t, pred) = case go t [] of [] -> Nothing; f:args -> Just (f,args) + where + go (App' i o) acc | pred o = go i (o:acc) + go _ [] = [] + go fn args = fn:args + +unBinaryApp :: Term2 vt at ap v a + -> Maybe (Term2 vt at ap v a, + Term2 vt at ap v a, + Term2 vt at ap v a) +unBinaryApp t = case unApps t of + Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) + _ -> Nothing + +-- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" +unBinaryApps + :: Term2 vt at ap v a + -> Maybe + ( [(Term2 vt at ap v a, Term2 vt at ap v a)] + , Term2 vt at ap v a + ) +unBinaryApps t = unBinaryAppsPred (t, const True) + +-- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. +unBinaryAppsPred :: (Term2 vt at ap v a + ,Term2 vt at ap v a -> Bool) + -> Maybe ([(Term2 vt at ap v a, + Term2 vt at ap v a)], + Term2 vt at ap v a) +unBinaryAppsPred (t, pred) = case unBinaryApp t of + Just (f, x, y) | pred f -> case unBinaryAppsPred (x, pred) of + Just (as, xLast) -> Just ((xLast, f) : as, y) + Nothing -> Just ([(x, f)], y) + _ -> Nothing + +unLams' + :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLams' t = unLamsPred' (t, const True) + +-- Same as unLams', but always matches. Returns an empty [v] if the term doesn't start with a +-- lambda extraction. +unLamsOpt' :: Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a) +unLamsOpt' t = case unLams' t of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams', but stops at any variable named `()`, which indicates a +-- delay (`'`) annotation which we want to preserve. +unLamsUntilDelay' + :: Var v + => Term2 vt at ap v a + -> Maybe ([v], Term2 vt at ap v a) +unLamsUntilDelay' t = case unLamsPred' (t, (/=) $ Var.named "()") of + r@(Just _) -> r + Nothing -> Just ([], t) + +-- Same as unLams' but taking a predicate controlling whether we match on a given binary function. +unLamsPred' :: (Term2 vt at ap v a, v -> Bool) -> + Maybe ([v], Term2 vt at ap v a) +unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of + Nothing -> Just ([v], body) + Just (vs, body) -> Just (v:vs, body) +unLamsPred' _ = Nothing + +unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId) +unReqOrCtor (Constructor' r cid) = Just (r, cid) +unReqOrCtor (Request' r cid) = Just (r, cid) +unReqOrCtor _ = Nothing + +-- Dependencies including referenced data and effect decls +dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t) + +termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +termDependencies = + Set.fromList + . mapMaybe + ( LD.fold + (\_typeRef -> Nothing) + ( Referent.fold + (\termRef -> Just termRef) + (\_typeConRef _i _ct -> Nothing) + ) + ) + . toList + . labeledDependencies + +-- gets types from annotations and constructors +typeDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +typeDependencies = + Set.fromList . mapMaybe (LD.fold Just (const Nothing)) . toList . labeledDependencies + +-- Gets the types to which this term contains references via patterns and +-- data constructors. +constructorDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference +constructorDependencies = + Set.unions + . generalizedDependencies (const mempty) + (const mempty) + Set.singleton + (const . Set.singleton) + Set.singleton + (const . Set.singleton) + Set.singleton + +generalizedDependencies + :: (Ord v, Ord vt, Ord r) + => (Reference -> r) + -> (Reference -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> (Reference -> ConstructorId -> r) + -> (Reference -> r) + -> Term2 vt at ap v a + -> Set r +generalizedDependencies termRef typeRef literalType dataConstructor dataType effectConstructor effectType + = Set.fromList . Writer.execWriter . ABT.visit' f where + f t@(Ref r) = Writer.tell [termRef r] $> t + f t@(TermLink r) = case r of + Referent.Ref r -> Writer.tell [termRef r] $> t + Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t + Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t + f t@(TypeLink r) = Writer.tell [typeRef r] $> t + f t@(Ann _ typ) = + Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t + f t@(Nat _) = Writer.tell [literalType Type.natRef] $> t + f t@(Int _) = Writer.tell [literalType Type.intRef] $> t + f t@(Float _) = Writer.tell [literalType Type.floatRef] $> t + f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t + f t@(Text _) = Writer.tell [literalType Type.textRef] $> t + f t@(List _) = Writer.tell [literalType Type.listRef] $> t + f t@(Constructor r cid) = + Writer.tell [dataType r, dataConstructor r cid] $> t + f t@(Request r cid) = + Writer.tell [effectType r, effectConstructor r cid] $> t + f t@(Match _ cases) = traverse_ goPat cases $> t + f t = pure t + goPat (MatchCase pat _ _) = + Writer.tell . toList $ Pattern.generalizedDependencies literalType + dataConstructor + dataType + effectConstructor + effectType + pat + +labeledDependencies + :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set LabeledDependency +labeledDependencies = generalizedDependencies LD.termRef + LD.typeRef + LD.typeRef + LD.dataConstructor + LD.typeRef + LD.effectConstructor + LD.typeRef + +updateDependencies + :: Ord v + => Map Reference Reference + -> Map Reference Reference + -> Term v a + -> Term v a +updateDependencies termUpdates typeUpdates = ABT.rebuildUp go + where + -- todo: this function might need tweaking if we ever allow type replacements + -- would need to look inside pattern matching and constructor calls + go (Ref r ) = Ref (Map.findWithDefault r r termUpdates) + go (TermLink (Referent.Ref r)) = TermLink (Referent.Ref $ Map.findWithDefault r r termUpdates) + go (TypeLink r) = TypeLink (Map.findWithDefault r r typeUpdates) + go (Ann tm tp) = Ann tm $ Type.updateDependencies typeUpdates tp + go f = f + +-- | If the outermost term is a function application, +-- perform substitution of the argument into the body +betaReduce :: Var v => Term0 v -> Term0 v +betaReduce (App' (Lam' f) arg) = ABT.bind f arg +betaReduce e = e + +betaNormalForm :: Var v => Term0 v -> Term0 v +betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a)) +betaNormalForm e = e + +-- x -> f x => f +etaNormalForm :: Ord v => Term0 v -> Term0 v +etaNormalForm tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaNormalForm body + where + step (LamNamed' v (App' f (Var' v'))) | v == v' = f + step tm = tm + _ -> tm + +-- x -> f x => f as long as `x` is a variable of type `Var.Eta` +etaReduceEtaVars :: Var v => Term0 v -> Term0 v +etaReduceEtaVars tm = case tm of + LamNamed' v body -> step . lam (ABT.annotation tm) v $ etaReduceEtaVars body + where + ok v v' = v == v' && Var.typeOf v == Var.Eta + step (LamNamed' v (App' f (Var' v'))) | ok v v' = f + step tm = tm + _ -> tm + +-- This converts `Reference`s it finds that are in the input `Map` +-- back to free variables +unhashComponent :: forall v a. Var v + => Map Reference (Term v a) + -> Map Reference (v, Term v a) +unhashComponent m = let + usedVars = foldMap (Set.fromList . ABT.allVars) m + m' :: Map Reference (v, Term v a) + m' = evalState (Map.traverseWithKey assignVar m) usedVars where + assignVar r t = (,t) <$> ABT.freshenS (refNamed r) + unhash1 = ABT.rebuildUp' go where + go e@(Ref' r) = case Map.lookup r m' of + Nothing -> e + Just (v, _) -> var (ABT.annotation e) v + go e = e + in second unhash1 <$> m' + where + -- Variable whose name is derived from the given reference. + refNamed :: Var v => Reference -> v + refNamed ref = Var.named ("ℍ" <> Reference.toText ref) + +hashComponents + :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +hashClosedTerm :: Var v => Term v a -> Reference.Id +hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 + +-- The hash for a constructor +hashConstructor' + :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference +hashConstructor' f r cid = + let +-- this is a bit circuitous, but defining everything in terms of hashComponents +-- ensure the hashing is always done in the same way + m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) + in case toList m of + [(r, _)] -> Reference.DerivedId r + _ -> error "unpossible" + +hashConstructor :: Reference -> ConstructorId -> Reference +hashConstructor = hashConstructor' $ constructor () + +hashRequest :: Reference -> ConstructorId -> Reference +hashRequest = hashConstructor' $ request () + +fromReferent :: Ord v + => a + -> Referent + -> Term2 vt at ap v a +fromReferent a = \case + Referent.Ref r -> ref a r + Referent.Con r i ct -> case ct of + CT.Data -> constructor a r i + CT.Effect -> request a r i + +instance Var v => Hashable1 (F v a p) where + hash1 hashCycle hash e + = let (tag, hashed, varint) = + (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) + in + case e of + -- So long as `Reference.Derived` ctors are created using the same + -- hashing function as is used here, this case ensures that references + -- are 'transparent' wrt hash and hashing is unaffected by whether + -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash + -- the same. + Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) + Ref (Reference.Derived h i n) -> Hashable.accumulate + [ tag 1 + , hashed $ Hashable.fromBytes (Hash.toBytes h) + , Hashable.Nat i + , Hashable.Nat n + ] + -- Note: start each layer with leading `1` byte, to avoid collisions + -- with types, which start each layer with leading `0`. + -- See `Hashable1 Type.F` + _ -> + Hashable.accumulate + $ tag 1 + : case e of + Nat i -> [tag 64, accumulateToken i] + Int i -> [tag 65, accumulateToken i] + Float n -> [tag 66, Hashable.Double n] + Boolean b -> [tag 67, accumulateToken b] + Text t -> [tag 68, accumulateToken t] + Char c -> [tag 69, accumulateToken c] + Blank b -> tag 1 : case b of + B.Blank -> [tag 0] + B.Recorded (B.Placeholder _ s) -> + [tag 1, Hashable.Text (Text.pack s)] + B.Recorded (B.Resolve _ s) -> + [tag 2, Hashable.Text (Text.pack s)] + Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] + Ref Reference.Derived {} -> + error "handled above, but GHC can't figure this out" + App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] + Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] + List as -> tag 5 : varint (Sequence.length as) : map + (hashed . hash) + (toList as) + Lam a -> [tag 6, hashed (hash a)] + -- note: we use `hashCycle` to ensure result is independent of + -- let binding order + LetRec _ as a -> case hashCycle as of + (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs + -- here, order is significant, so don't use hashCycle + Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + If b t f -> + [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] + Request r n -> [tag 10, accumulateToken r, varint n] + Constructor r n -> [tag 12, accumulateToken r, varint n] + Match e branches -> + tag 13 : hashed (hash e) : concatMap h branches + where + h (MatchCase pat guard branch) = concat + [ [accumulateToken pat] + , toList (hashed . hash <$> guard) + , [hashed (hash branch)] + ] + Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] + And x y -> [tag 16, hashed $ hash x, hashed $ hash y] + Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] + TermLink r -> [tag 18, accumulateToken r] + TypeLink r -> [tag 19, accumulateToken r] + +-- mostly boring serialization code below ... + +instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec + +instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where + Int x == Int y = x == y + Nat x == Nat y = x == y + Float x == Float y = x == y + Boolean x == Boolean y = x == y + Text x == Text y = x == y + Char x == Char y = x == y + Blank b == Blank q = b == q + Ref x == Ref y = x == y + TermLink x == TermLink y = x == y + TypeLink x == TypeLink y = x == y + Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2 + Request r cid == Request r2 cid2 = r == r2 && cid == cid2 + Handle h b == Handle h2 b2 = h == h2 && b == b2 + App f a == App f2 a2 = f == f2 && a == a2 + Ann e t == Ann e2 t2 = e == e2 && t == t2 + List v == List v2 = v == v2 + If a b c == If a2 b2 c2 = a == a2 && b == b2 && c == c2 + And a b == And a2 b2 = a == a2 && b == b2 + Or a b == Or a2 b2 = a == a2 && b == b2 + Lam a == Lam b = a == b + LetRec _ bs body == LetRec _ bs2 body2 = bs == bs2 && body == body2 + Let _ binding body == Let _ binding2 body2 = + binding == binding2 && body == body2 + Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 + _ == _ = False + + +instance (Show v, Show a) => Show (F v a0 p a) where + showsPrec = go + where + go _ (Int n ) = (if n >= 0 then s "+" else s "") <> shows n + go _ (Nat n ) = shows n + go _ (Float n ) = shows n + go _ (Boolean True ) = s "true" + go _ (Boolean False) = s "false" + go p (Ann t k) = showParen (p > 1) $ shows t <> s ":" <> shows k + go p (App f x) = showParen (p > 9) $ showsPrec 9 f <> s " " <> showsPrec 10 x + go _ (Lam body ) = showParen True (s "λ " <> shows body) + go _ (List vs ) = showListWith shows (toList vs) + go _ (Blank b ) = case b of + B.Blank -> s "_" + B.Recorded (B.Placeholder _ r) -> s ("_" ++ r) + B.Recorded (B.Resolve _ r) -> s r + go _ (Ref r) = s "Ref(" <> shows r <> s ")" + go _ (TermLink r) = s "TermLink(" <> shows r <> s ")" + go _ (TypeLink r) = s "TypeLink(" <> shows r <> s ")" + go _ (Let _ b body) = + showParen True (s "let " <> shows b <> s " in " <> shows body) + go _ (LetRec _ bs body) = showParen + True + (s "let rec" <> shows bs <> s " in " <> shows body) + go _ (Handle b body) = showParen + True + (s "handle " <> shows b <> s " in " <> shows body) + go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n + go _ (Match scrutinee cases) = showParen + True + (s "case " <> shows scrutinee <> s " of " <> shows cases) + go _ (Text s ) = shows s + go _ (Char c ) = shows c + go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n + go p (If c t f) = + showParen (p > 0) + $ s "if " + <> shows c + <> s " then " + <> shows t + <> s " else " + <> shows f + go p (And x y) = + showParen (p > 0) $ s "and " <> shows x <> s " " <> shows y + go p (Or x y) = + showParen (p > 0) $ s "or " <> shows x <> s " " <> shows y + (<>) = (.) + s = showString \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Type.hs b/parser-typechecker/src/Unison/Hashing/V2/Type.hs new file mode 100644 index 0000000000..cc2a6e0dc4 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Type.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Hashing.V2.Type where + +import Unison.Prelude + +import qualified Control.Monad.Writer.Strict as Writer +import Data.Functor.Identity (runIdentity) +import Data.Monoid (Any(..)) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) +import qualified Unison.ABT as ABT +import Unison.Hashable (Hashable1) +import qualified Unison.Hashable as Hashable +import qualified Unison.Kind as K +import Unison.Hashing.V2.Reference (Reference) +import qualified Unison.Hashing.V2.Reference as Reference +import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil +import Unison.Var (Var) +import qualified Unison.Var as Var +import qualified Unison.Settings as Settings +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Name as Name +import qualified Unison.Util.List as List + +-- | Base functor for types in the Unison language +data F a + = Ref Reference + | Arrow a a + | Ann a K.Kind + | App a a + | Effect a a + | Effects [a] + | Forall a + | IntroOuter a -- binder like ∀, used to introduce variables that are + -- bound by outer type signatures, to support scoped type + -- variables + deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable) + +instance Eq1 F where (==#) = (==) +instance Ord1 F where compare1 = compare +instance Show1 F where showsPrec1 = showsPrec + +-- | Types are represented as ABTs over the base functor F, with variables in `v` +type Type v a = ABT.Term F v a + +wrapV :: Ord v => Type v a -> Type (ABT.V v) a +wrapV = ABT.vmap ABT.Bound + +freeVars :: Type v a -> Set v +freeVars = ABT.freeVars + +bindExternal + :: ABT.Var v => [(v, Reference)] -> Type v a -> Type v a +bindExternal bs = ABT.substsInheritAnnotation [ (v, ref () r) | (v, r) <- bs ] + +bindReferences + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindReferences keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +bindNames + :: Var v + => Set v + -> Map Name.Name Reference + -> Type v a + -> Names.ResolutionResult v a (Type v a) +bindNames keepFree ns t = let + fvs = ABT.freeVarOccurrences keepFree t + rs = [(v, a, Map.lookup (Name.fromVar v) ns) | (v, a) <- fvs] + ok (v, _a, Just r) = pure (v, r) + ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a mempty)) + in List.validate ok rs <&> \es -> bindExternal es t + +newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq + +instance (Show v) => Show (Monotype v a) where + show = show . getPolytype + +-- Smart constructor which checks if a `Type` has no `Forall` quantifiers. +monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a) +monotype t = Monotype <$> ABT.visit isMono t where + isMono (Forall' _) = Just Nothing + isMono _ = Nothing + +arity :: Type v a -> Int +arity (ForallNamed' _ body) = arity body +arity (Arrow' _ o) = 1 + arity o +arity (Ann' a _) = arity a +arity _ = 0 + +-- some smart patterns +pattern Ref' r <- ABT.Tm' (Ref r) +pattern Arrow' i o <- ABT.Tm' (Arrow i o) +pattern Arrow'' i es o <- Arrow' i (Effect'' es o) +pattern Arrows' spine <- (unArrows -> Just spine) +pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest)) +pattern Ann' t k <- ABT.Tm' (Ann t k) +pattern App' f x <- ABT.Tm' (App f x) +pattern Apps' f args <- (unApps -> Just (f, args)) +pattern Pure' t <- (unPure -> Just t) +pattern Effects' es <- ABT.Tm' (Effects es) +-- Effect1' must match at least one effect +pattern Effect1' e t <- ABT.Tm' (Effect e t) +pattern Effect' es t <- (unEffects1 -> Just (es, t)) +pattern Effect'' es t <- (unEffect0 -> (es, t)) +-- Effect0' may match zero effects +pattern Effect0' es t <- (unEffect0 -> (es, t)) +pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst)) +pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst)) +pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body)) +pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body)) +pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body)) +pattern Var' v <- ABT.Var' v +pattern Cycle' xs t <- ABT.Cycle' xs t +pattern Abs' subst <- ABT.Abs' subst + +unPure :: Ord v => Type v a -> Maybe (Type v a) +unPure (Effect'' [] t) = Just t +unPure (Effect'' _ _) = Nothing +unPure t = Just t + +unArrows :: Type v a -> Maybe [Type v a] +unArrows t = + case go t of [_] -> Nothing; l -> Just l + where go (Arrow' i o) = i : go o + go o = [o] + +unEffectfulArrows + :: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)]) +unEffectfulArrows t = case t of + Arrow' i o -> Just (i, go o) + _ -> Nothing + where + go (Effect1' (Effects' es) (Arrow' i o)) = + (Just $ es >>= flattenEffects, i) : go o + go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)] + go (Arrow' i o) = (Nothing, i) : go o + go t = [(Nothing, t)] + +unApps :: Type v a -> Maybe (Type v a, [Type v a]) +unApps t = case go t [] of + [] -> Nothing + [ _ ] -> Nothing + f : args -> Just (f, args) + where + go (App' i o) acc = go i (o : acc) + go fn args = fn : args + +unIntroOuters :: Type v a -> Maybe ([v], Type v a) +unIntroOuters t = go t [] + where go (IntroOuterNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just (reverse vs, body) + +-- Most code doesn't care about `introOuter` binders and is fine dealing with the +-- these outer variable references as free variables. This function strips out +-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`. +stripIntroOuters :: Type v a -> Type v a +stripIntroOuters t = case unIntroOuters t of + Just (_, t) -> t + Nothing -> t + +unForalls :: Type v a -> Maybe ([v], Type v a) +unForalls t = go t [] + where go (ForallNamed' v body) vs = go body (v:vs) + go _body [] = Nothing + go body vs = Just(reverse vs, body) + +unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a) +unEffect0 (Effect1' e a) = (flattenEffects e, a) +unEffect0 t = ([], t) + +unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a) +unEffects1 (Effect1' (Effects' es) a) = Just (es, a) +unEffects1 _ = Nothing + +-- | True if the given type is a function, possibly quantified +isArrow :: ABT.Var v => Type v a -> Bool +isArrow (ForallNamed' _ t) = isArrow t +isArrow (Arrow' _ _) = True +isArrow _ = False + +-- some smart constructors + +ref :: Ord v => a -> Reference -> Type v a +ref a = ABT.tm' a . Ref + +refId :: Ord v => a -> Reference.Id -> Type v a +refId a = ref a . Reference.DerivedId + +termLink :: Ord v => a -> Type v a +termLink a = ABT.tm' a . Ref $ termLinkRef + +typeLink :: Ord v => a -> Type v a +typeLink a = ABT.tm' a . Ref $ typeLinkRef + +derivedBase32Hex :: Ord v => Reference -> a -> Type v a +derivedBase32Hex r a = ref a r + +intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference +intRef = Reference.Builtin "Int" +natRef = Reference.Builtin "Nat" +floatRef = Reference.Builtin "Float" +booleanRef = Reference.Builtin "Boolean" +textRef = Reference.Builtin "Text" +charRef = Reference.Builtin "Char" +listRef = Reference.Builtin "Sequence" +bytesRef = Reference.Builtin "Bytes" +effectRef = Reference.Builtin "Effect" +termLinkRef = Reference.Builtin "Link.Term" +typeLinkRef = Reference.Builtin "Link.Type" + +builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference +builtinIORef = Reference.Builtin "IO" +fileHandleRef = Reference.Builtin "Handle" +filePathRef = Reference.Builtin "FilePath" +threadIdRef = Reference.Builtin "ThreadId" +socketRef = Reference.Builtin "Socket" + +mvarRef, tvarRef :: Reference +mvarRef = Reference.Builtin "MVar" +tvarRef = Reference.Builtin "TVar" + +tlsRef :: Reference +tlsRef = Reference.Builtin "Tls" + +stmRef :: Reference +stmRef = Reference.Builtin "STM" + +tlsClientConfigRef :: Reference +tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" + +tlsServerConfigRef :: Reference +tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig" + +tlsSignedCertRef :: Reference +tlsSignedCertRef = Reference.Builtin "Tls.SignedCert" + +tlsPrivateKeyRef :: Reference +tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey" + +tlsCipherRef :: Reference +tlsCipherRef = Reference.Builtin "Tls.Cipher" + +tlsVersionRef :: Reference +tlsVersionRef = Reference.Builtin "Tls.Version" + +hashAlgorithmRef :: Reference +hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm" + +codeRef, valueRef :: Reference +codeRef = Reference.Builtin "Code" +valueRef = Reference.Builtin "Value" + +anyRef :: Reference +anyRef = Reference.Builtin "Any" + +any :: Ord v => a -> Type v a +any a = ref a anyRef + +builtin :: Ord v => a -> Text -> Type v a +builtin a = ref a . Reference.Builtin + +int :: Ord v => a -> Type v a +int a = ref a intRef + +nat :: Ord v => a -> Type v a +nat a = ref a natRef + +float :: Ord v => a -> Type v a +float a = ref a floatRef + +boolean :: Ord v => a -> Type v a +boolean a = ref a booleanRef + +text :: Ord v => a -> Type v a +text a = ref a textRef + +char :: Ord v => a -> Type v a +char a = ref a charRef + +fileHandle :: Ord v => a -> Type v a +fileHandle a = ref a fileHandleRef + +threadId :: Ord v => a -> Type v a +threadId a = ref a threadIdRef + +builtinIO :: Ord v => a -> Type v a +builtinIO a = ref a builtinIORef + +socket :: Ord v => a -> Type v a +socket a = ref a socketRef + +list :: Ord v => a -> Type v a +list a = ref a listRef + +bytes :: Ord v => a -> Type v a +bytes a = ref a bytesRef + +effectType :: Ord v => a -> Type v a +effectType a = ref a $ effectRef + +code, value :: Ord v => a -> Type v a +code a = ref a codeRef +value a = ref a valueRef + +app :: Ord v => a -> Type v a -> Type v a -> Type v a +app a f arg = ABT.tm' a (App f arg) + +-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one +-- meant for `app (f x) y` +apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a +apps = foldl' go where go f (a, t) = app a f t + +app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a +app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg + +apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a +apps' = foldl app' + +arrow :: Ord v => a -> Type v a -> Type v a -> Type v a +arrow a i o = ABT.tm' a (Arrow i o) + +arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a +arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o + +ann :: Ord v => a -> Type v a -> K.Kind -> Type v a +ann a e t = ABT.tm' a (Ann e t) + +forall :: Ord v => a -> v -> Type v a -> Type v a +forall a v body = ABT.tm' a (Forall (ABT.abs' a v body)) + +introOuter :: Ord v => a -> v -> Type v a -> Type v a +introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) + +iff :: Var v => Type v () +iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a + where aa = Var.named "a" + a = var () aa + f x = ((), x) + +iff' :: Var v => a -> Type v a +iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +iff2 :: Var v => a -> Type v a +iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a + where aa = Var.named "a" + a = var loc aa + f x = (loc, x) + +andor :: Ord v => Type v () +andor = arrows (f <$> [boolean(), boolean()]) $ boolean() + where f x = ((), x) + +andor' :: Ord v => a -> Type v a +andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a + where f x = (a, x) + +var :: Ord v => a -> v -> Type v a +var = ABT.annotatedVar + +v' :: Var v => Text -> Type v () +v' s = ABT.var (Var.named s) + +-- Like `v'`, but creates an annotated variable given an annotation +av' :: Var v => a -> Text -> Type v a +av' a s = ABT.annotatedVar a (Var.named s) + +forall' :: Var v => a -> [Text] -> Type v a -> Type v a +forall' a vs body = foldr (forall a) body (Var.named <$> vs) + +foralls :: Ord v => a -> [v] -> Type v a -> Type v a +foralls a vs body = foldr (forall a) body vs + +-- Note: `a -> b -> c` parses as `a -> (b -> c)` +-- the annotation associated with `b` will be the annotation for the `b -> c` +-- node +arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a +arrows ts result = foldr go result ts where + go = uncurry arrow + +-- The types of effectful computations +effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a +effect a es (Effect1' fs t) = + let es' = (es >>= flattenEffects) ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t) + +effects :: Ord v => a -> [Type v a] -> Type v a +effects a es = ABT.tm' a (Effects $ es >>= flattenEffects) + +effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a +effect1 a es (Effect1' fs t) = + let es' = flattenEffects es ++ flattenEffects fs + in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t) +effect1 a es t = ABT.tm' a (Effect es t) + +flattenEffects :: Type v a -> [Type v a] +flattenEffects (Effects' es) = es >>= flattenEffects +flattenEffects es = [es] + +-- The types of first-class effect values +-- which get deconstructed in effect handlers. +effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a +effectV builtinA e t = apps (builtin builtinA "Effect") [e, t] + +-- Strips effects from a type. E.g. `{e} a` becomes `a`. +stripEffect :: Ord v => Type v a -> ([Type v a], Type v a) +stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) +stripEffect t = ([], t) + +-- The type of the flipped function application operator: +-- `(a -> (a -> b) -> b)` +flipApply :: Var v => Type v () -> Type v () +flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b) + where b = ABT.fresh t (Var.named "b") + +generalize' :: Var v => Var.Type -> Type v a -> Type v a +generalize' k t = generalize vsk t where + vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ] + +-- | Bind the given variables with an outer `forall`, if they are used in `t`. +generalize :: Ord v => [v] -> Type v a -> Type v a +generalize vs t = foldr f t vs + where + f v t = + if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t + +unforall :: Type v a -> Type v a +unforall (ForallsNamed' _ t) = t +unforall t = t + +unforall' :: Type v a -> ([v], Type v a) +unforall' (ForallsNamed' vs t) = (vs, t) +unforall' t = ([], t) + +dependencies :: Ord v => Type v a -> Set Reference +dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t + where f t@(Ref r) = Writer.tell [r] $> t + f t = pure t + +updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a +updateDependencies typeUpdates = ABT.rebuildUp go + where + go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) + go f = f + +usesEffects :: Ord v => Type v a -> Bool +usesEffects t = getAny . getConst $ ABT.visit go t where + go (Effect1' _ _) = Just (Const (Any True)) + go _ = Nothing + +-- Returns free effect variables in the given type, for instance, in: +-- +-- ∀ e3 . a ->{e,e2} b ->{e3} c +-- +-- This function would return the set {e, e2}, but not `e3` since `e3` +-- is bound by the enclosing forall. +freeEffectVars :: Ord v => Type v a -> Set v +freeEffectVars t = + Set.fromList . join . runIdentity $ + ABT.foreachSubterm go (snd <$> ABT.annotateBound t) + where + go t@(Effects' es) = + let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go t@(Effect1' e _) = + let frees = Set.fromList [ v | Var' v <- flattenEffects e ] + in pure . Set.toList $ frees `Set.difference` ABT.annotation t + go _ = pure [] + +-- Converts all unadorned arrows in a type to have fresh +-- existential ability requirements. For example: +-- +-- (a -> b) -> [a] -> [b] +-- +-- Becomes +-- +-- (a ->{e1} b) ->{e2} [a] ->{e3} [b] +existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a) +existentializeArrows newVar t = ABT.visit go t + where + go t@(Arrow' a b) = case b of + -- If an arrow already has attached abilities, + -- leave it alone. Ex: `a ->{e} b` is kept as is. + Effect1' _ _ -> Just $ do + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + pure $ arrow (ABT.annotation t) a b + -- For unadorned arrows, make up a fresh variable. + -- So `a -> b` becomes `a ->{e} b`, using the + -- `newVar` variable generator. + _ -> Just $ do + e <- newVar + a <- existentializeArrows newVar a + b <- existentializeArrows newVar b + let ann = ABT.annotation t + pure $ arrow ann a (effect ann [var ann e] b) + go _ = Nothing + +purifyArrows :: (Ord v) => Type v a -> Type v a +purifyArrows = ABT.visitPure go + where + go t@(Arrow' a b) = case b of + Effect1' _ _ -> Nothing + _ -> Just $ arrow ann a (effect ann [] b) + where ann = ABT.annotation t + go _ = Nothing + +-- Remove free effect variables from the type that are in the set +removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a +removeEffectVars removals t = + let z = effects () [] + t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t + -- leave explicitly empty `{}` alone + removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v) + removeEmpty t@(Effect1' e v) = + case flattenEffects e of + [] -> Just (ABT.visitPure removeEmpty v) + es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v) + removeEmpty t@(Effects' es) = + Just $ effects (ABT.annotation t) (es >>= flattenEffects) + removeEmpty _ = Nothing + in ABT.visitPure removeEmpty t' + +-- Remove all effect variables from the type. +-- Used for type-based search, we apply this transformation to both the +-- indexed type and the query type, so the user can supply `a -> b` that will +-- match `a ->{e} b` (but not `a ->{IO} b`). +removeAllEffectVars :: ABT.Var v => Type v a -> Type v a +removeAllEffectVars t = let + allEffectVars = foldMap go (ABT.subterms t) + go (Effects' vs) = Set.fromList [ v | Var' v <- vs] + go (Effect1' (Var' v) _) = Set.singleton v + go _ = mempty + (vs, tu) = unforall' t + in generalize vs (removeEffectVars allEffectVars tu) + +removePureEffects :: ABT.Var v => Type v a -> Type v a +removePureEffects t | not Settings.removePureEffects = t + | otherwise = + generalize vs $ removeEffectVars (Set.filter isPure fvs) tu + where + (vs, tu) = unforall' t + fvs = freeEffectVars tu `Set.difference` ABT.freeVars t + -- If an effect variable is mentioned only once, it is on + -- an arrow `a ->{e} b`. Generalizing this to + -- `∀ e . a ->{e} b` gives us the pure arrow `a -> b`. + isPure v = ABT.occurrences v tu <= 1 + +editFunctionResult + :: forall v a + . Ord v + => (Type v a -> Type v a) + -> Type v a + -> Type v a +editFunctionResult f = go + where + go :: Type v a -> Type v a + go (ABT.Term s a t) = case t of + ABT.Tm (Forall t) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t + ABT.Tm (Arrow i o) -> + (\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o + ABT.Abs v r -> + (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r + _ -> f (ABT.Term s a t) + +functionResult :: Type v a -> Maybe (Type v a) +functionResult = go False + where + go inArr (ForallNamed' _ body) = go inArr body + go _inArr (Arrow' _i o ) = go True o + go inArr t = if inArr then Just t else Nothing + + +-- | Bind all free variables (not in `except`) that start with a lowercase +-- letter and are unqualified with an outer `forall`. +-- `a -> a` becomes `∀ a . a -> a` +-- `B -> B` becomes `B -> B` (not changed) +-- `.foo -> .foo` becomes `.foo -> .foo` (not changed) +-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged) +generalizeLowercase :: Var v => Set v -> Type v a -> Type v a +generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars + where + vars = + [ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ] + +-- Convert all free variables in `allowed` to variables bound by an `introOuter`. +freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a +freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars + where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed + +-- | This function removes all variable shadowing from the types and reduces +-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing +-- two different types. +cleanupVars :: Var v => [Type v a] -> [Type v a] +cleanupVars ts | not Settings.cleanupTypes = ts +cleanupVars ts = let + changedVars = cleanupVarsMap ts + in cleanupVars1' changedVars <$> ts + +-- Compute a variable replacement map from a collection of types, which +-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids +-- for multiple related types, like when reporting a type error. +cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v +cleanupVarsMap ts = let + varsByName = foldl' step Map.empty (ts >>= ABT.allVars) + step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m + changedVars = Map.fromList [ (v, Var.freshenId i v) + | (_, vs) <- Map.toList varsByName + , (v,i) <- nubOrd vs `zip` [0..]] + in changedVars + +cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a +cleanupVars1' = ABT.changeVars + +-- | This function removes all variable shadowing from the type and reduces +-- fresh ids to the minimum possible to avoid ambiguity. +cleanupVars1 :: Var v => Type v a -> Type v a +cleanupVars1 t | not Settings.cleanupTypes = t +cleanupVars1 t = let [t'] = cleanupVars [t] in t' + +-- This removes duplicates and normalizes the order of ability lists +cleanupAbilityLists :: Var v => Type v a -> Type v a +cleanupAbilityLists = ABT.visitPure go + where + -- leave explicitly empty `{}` alone + go (Effect1' (Effects' []) _v) = Nothing + go t@(Effect1' e v) = + let es = Set.toList . Set.fromList $ flattenEffects e + in case es of + [] -> Just (ABT.visitPure go v) + _ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v) + go _ = Nothing + +cleanups :: Var v => [Type v a] -> [Type v a] +cleanups ts = cleanupVars $ map cleanupAbilityLists ts + +cleanup :: Var v => Type v a -> Type v a +cleanup t | not Settings.cleanupTypes = t +cleanup t = cleanupVars1 . cleanupAbilityLists $ t + +toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference (Ref' r) = r +-- a bit of normalization - any unused type parameters aren't part of the hash +toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body +toReference t = Reference.Derived (ABT.hash t) 0 1 + +toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions ty = + let (vs, _) = unforall' ty + gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty + in Set.fromList $ toReference . gen <$> ABT.subterms ty + +hashComponents + :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) +hashComponents = ReferenceUtil.hashComponents $ refId () + +instance Hashable1 F where + hash1 hashCycle hash e = + let + (tag, hashed) = (Hashable.Tag, Hashable.Hashed) + -- Note: start each layer with leading `0` byte, to avoid collisions with + -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` + in Hashable.accumulate $ tag 0 : case e of + Ref r -> [tag 0, Hashable.accumulateToken r] + Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] + App a b -> [tag 2, hashed (hash a), hashed (hash b) ] + Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] + -- Example: + -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as + -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from + -- c) {Remote, Abort} (() -> {Abort} ()) + Effects es -> let + (hs, _) = hashCycle es + in tag 4 : map hashed hs + Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] + Forall a -> [tag 6, hashed (hash a)] + IntroOuter a -> [tag 7, hashed (hash a)] + +instance Show a => Show (F a) where + showsPrec = go where + go _ (Ref r) = shows r + go p (Arrow i o) = + showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o + go p (Ann t k) = + showParen (p > 1) $ shows t <> s":" <> shows k + go p (App f x) = + showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x + go p (Effects es) = showParen (p > 0) $ + s"{" <> shows es <> s"}" + go p (Effect e t) = showParen (p > 0) $ + showParen True $ shows e <> s" " <> showsPrec p t + go p (Forall body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"∀ " <> shows body + go p (IntroOuter body) = case p of + 0 -> showsPrec p body + _ -> showParen True $ s"outer " <> shows body + (<>) = (.) + s = showString diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index 925294e04e..54ff966c9c 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -56,7 +56,7 @@ termNamed s = fromMaybe (error $ "No builtin term called: " <> s) $ Map.lookup (Var.nameds s) typecheckedFileTerms codeLookup :: CodeLookup Symbol Identity Ann -codeLookup = CL.fromUnisonFile $ UF.discardTypes typecheckedFile +codeLookup = CL.fromTypecheckedUnisonFile typecheckedFile typeNamedId :: String -> R.Id typeNamedId s = diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index a2e6bd33e3..b95496dd79 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -63,6 +63,7 @@ import Unison.Runtime.Machine ) import Unison.Runtime.Pattern import Unison.Runtime.Stack +import qualified Unison.Hashing.V2.Convert as Hashing type Term v = Tm.Term v () @@ -254,12 +255,12 @@ prepareEvaluation ppe tm ctx = do (rmn, rtms) | Tm.LetRecNamed' bs mn0 <- tm , hcs <- fmap (first RF.DerivedId) - . Tm.hashComponents $ Map.fromList bs + . Hashing.hashTermComponents $ Map.fromList bs , mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0 - , rmn <- RF.DerivedId $ Tm.hashClosedTerm mn + , rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn = (rmn , (rmn, mn) : Map.elems hcs) - | rmn <- RF.DerivedId $ Tm.hashClosedTerm tm + | rmn <- RF.DerivedId $ Hashing.hashClosedTerm tm = (rmn, [(rmn, tm)]) (rgrp, rbkr) = intermediateTerms ppe ctx rtms diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 5dafb99534..36629ae64c 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -93,6 +93,7 @@ import qualified Unison.Server.Doc as Doc import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject import qualified Unison.WatchKind as WK import qualified Unison.PrettyPrintEnv.Util as PPE +import qualified Unison.Hashing.V2.Convert as Hashing type SyntaxText = UST.SyntaxText' Reference @@ -751,7 +752,7 @@ renderDoc ppe width rt codebase r = do Codebase.putWatch codebase WK.RegularWatch - (Term.hashClosedTerm tm) + (Hashing.hashClosedTerm tm) (Term.amap (const mempty) tmr) Nothing -> pure () pure $ r <&> Term.amap (const mempty) diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 2b7b3ec818..bb12e749c9 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -42,6 +42,7 @@ import qualified Unison.Builtin.Decls as DD import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import qualified Unison.DataDeclaration as DD +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.LabeledDependency (LabeledDependency) import qualified Unison.LabeledDependency as LD import Unison.Reference (Reference) @@ -56,7 +57,6 @@ import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), patt import qualified Unison.Util.List as List import Unison.Var (Var) import Unison.WatchKind (WatchKind, pattern TestWatch) - dataDeclarations :: UnisonFile v a -> Map v (Reference, DataDeclaration v a) dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId @@ -89,7 +89,7 @@ dataDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, DataDeclarat dataDeclarations' = fmap (first Reference.DerivedId) . dataDeclarationsId' effectDeclarations' :: TypecheckedUnisonFile v a -> Map v (Reference, EffectDeclaration v a) effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId' -hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Term v a, Type v a) +hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Maybe WatchKind, Term v a, Type v a) hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId -- todo: this is confusing, right? @@ -111,9 +111,15 @@ typecheckedUnisonFile datas effects tlcs watches = components = topLevelComponents file types = Map.fromList [(v,t) | (v,_,t) <- join components ] terms0 = Map.fromList [(v,e) | (v,e,_) <- join components ] - hcs = Term.hashComponents terms0 - in Map.fromList [ (v, (r, e, t)) | (v, (r, e)) <- Map.toList hcs, - Just t <- [Map.lookup v types] ] + watchKinds = Map.fromList $ + [(v,Nothing) | (v,_e,_t) <- join $ topLevelComponents' file] + ++ [(v, Just wk) | (wk, terms) <- watches, (v, _e, _t) <- terms ] + hcs = Hashing.hashTermComponents terms0 + in Map.fromList + [ (v, (r, wk, e, t)) + | (v, (r, e)) <- Map.toList hcs + , Just t <- [Map.lookup v types] + , Just wk <- [Map.lookup v watchKinds] ] lookupDecl :: Ord v => v -> TypecheckedUnisonFile v a -> Maybe (Reference.Id, DD.Decl v a) @@ -128,12 +134,13 @@ indexByReference uf = (tms, tys) tys = Map.fromList (over _2 Right <$> toList (dataDeclarationsId' uf)) <> Map.fromList (over _2 Left <$> toList (effectDeclarationsId' uf)) tms = Map.fromList [ - (r, (tm,ty)) | (Reference.DerivedId r, tm, ty) <- toList (hashTerms uf) ] + (r, (tm,ty)) | (Reference.DerivedId r, _wk, tm, ty) <- toList (hashTerms uf) ] allTerms :: Ord v => TypecheckedUnisonFile v a -> Map v (Term v a) allTerms uf = Map.fromList [ (v, t) | (v, t, _) <- join $ topLevelComponents' uf ] +-- |the top level components (no watches) plus test watches. topLevelComponents :: TypecheckedUnisonFile v a -> [[(v, Term v a, Type v a)]] topLevelComponents file = @@ -147,7 +154,7 @@ termSignatureExternalLabeledDependencies Set.difference (Set.map LD.typeRef . foldMap Type.dependencies - . fmap (\(_r, _e, t) -> t) + . fmap (\(_r, _wk, _e, t) -> t) . toList $ hashTerms) -- exclude any references that are defined in this file diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index 9925918434..fff4ba981f 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -9,9 +9,10 @@ import Data.Bifunctor (second) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Unison.ABT as ABT -import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..), hashDecls) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) import qualified Unison.DataDeclaration as DD import qualified Unison.DataDeclaration.Names as DD.Names +import qualified Unison.Hashing.V2.Convert as Hashing import qualified Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names import Unison.Names3 (Names0) @@ -20,10 +21,10 @@ import Unison.Prelude import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.Term as Term -import Unison.UnisonFile.Env (Env(..)) -import Unison.UnisonFile.Error (Error (UnknownType, DupDataAndAbility)) -import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) import qualified Unison.UnisonFile as UF +import Unison.UnisonFile.Env (Env (..)) +import Unison.UnisonFile.Error (Error (DupDataAndAbility, UnknownType)) +import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) import qualified Unison.Util.Relation as Relation import Unison.Var (Var) @@ -37,7 +38,7 @@ typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where terms = Relation.fromList [ (Name.fromVar v, Referent.Ref r) - | (v, (r, _, _)) <- Map.toList $ UF.hashTerms uf ] + | (v, (r, _, _, _)) <- Map.toList $ UF.hashTerms uf ] types = Relation.fromList [ (Name.fromVar v, r) | (v, r) <- Map.toList $ fmap fst (UF.dataDeclarations' uf) @@ -96,8 +97,7 @@ environmentFor names dataDecls0 effectDecls0 = do traverse (DD.withEffectDeclM (DD.Names.bindNames locallyBoundTypes names)) effectDecls0 let allDecls0 :: Map v (DataDeclaration v a) allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) - hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- - hashDecls allDecls0 + hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDecls allDecls0 -- then we have to pick out the dataDecls from the effectDecls let allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ] diff --git a/parser-typechecker/src/Unison/UnisonFile/Type.hs b/parser-typechecker/src/Unison/UnisonFile/Type.hs index 218829ebfa..f48a4688ac 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Type.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Type.hs @@ -8,12 +8,12 @@ module Unison.UnisonFile.Type where import Unison.Prelude import Control.Lens -import Data.Bifunctor (first) -import Unison.DataDeclaration (DataDeclaration) -import Unison.DataDeclaration (EffectDeclaration(..)) -import qualified Unison.Reference as Reference -import Unison.Term (Term) -import Unison.Type (Type) +import Data.Bifunctor (first) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..)) +import qualified Unison.Reference as Reference +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) import Unison.WatchKind (WatchKind) data UnisonFile v a = UnisonFileId { @@ -38,7 +38,7 @@ data TypecheckedUnisonFile v a = effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a), topLevelComponents' :: [[(v, Term v a, Type v a)]], watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])], - hashTermsId :: Map v (Reference.Id, Term v a, Type v a) + hashTermsId :: Map v (Reference.Id, Maybe WatchKind, Term v a, Type v a) } deriving Show {-# COMPLETE TypecheckedUnisonFile #-} @@ -48,3 +48,13 @@ pattern TypecheckedUnisonFile ds es tlcs wcs hts <- tlcs wcs (fmap (over _1 Reference.DerivedId) -> hts) + +instance Ord v => Functor (TypecheckedUnisonFile v) where + fmap f (TypecheckedUnisonFileId ds es tlcs wcs hashTerms) = + TypecheckedUnisonFileId ds' es' tlcs' wcs' hashTerms' + where + ds' = fmap (\(id, dd) -> (id, fmap f dd)) ds + es' = fmap (\(id, ed) -> (id, fmap f ed)) es + tlcs' = (fmap.fmap) (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tlcs + wcs' = map (\(wk, tms) -> (wk, map (\(v, tm, tp) -> (v, Term.amap f tm, fmap f tp)) tms)) wcs + hashTerms' = fmap (\(id, wk, tm, tp) -> (id, wk, Term.amap f tm, fmap f tp)) hashTerms diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 613c549117..c4dddf56b6 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -2,26 +2,27 @@ module Unison.Test.DataDeclaration where -import qualified Data.Map as Map -import Data.Map ( Map, (!) ) -import EasyTest -import Text.RawString.QQ +import Data.Map (Map, (!)) +import qualified Data.Map as Map +import EasyTest +import Text.RawString.QQ +import Unison.DataDeclaration (DataDeclaration (..), Decl) import qualified Unison.DataDeclaration as DD -import Unison.DataDeclaration ( DataDeclaration(..), Decl, hashDecls ) -import qualified Unison.Hash as Hash +import qualified Unison.Hash as Hash +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.Parser.Ann (Ann) -import Unison.Parsers ( unsafeParseFile ) -import qualified Unison.Reference as R -import Unison.Symbol ( Symbol ) -import qualified Unison.Test.Common as Common -import qualified Unison.Type as Type -import Unison.UnisonFile ( UnisonFile(..) ) -import qualified Unison.Var as Var +import Unison.Parsers (unsafeParseFile) +import qualified Unison.Reference as R +import Unison.Symbol (Symbol) +import qualified Unison.Test.Common as Common +import qualified Unison.Type as Type +import Unison.UnisonFile (UnisonFile (..)) +import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var test :: Test () test = scope "datadeclaration" $ - let Right hashes = hashDecls . (snd <$>) . dataDeclarationsId $ file + let Right hashes = Hashing.hashDecls . (snd <$>) . dataDeclarationsId $ file hashMap = Map.fromList $ fmap (\(a,b,_) -> (a,b)) hashes hashOf k = Map.lookup (Var.named k) hashMap in tests [ diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 28d716ea9f..700ae12097 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -128,7 +128,6 @@ resultTest rt uf filepath = do if rFileExists then scope "result" $ do values <- io $ unpack <$> Data.Text.IO.readFile valueFile - let untypedFile = UF.discardTypes uf let term = Parsers.parseTerm values parsingEnv let report e = throwIO (userError $ toPlain 10000 e) (bindings, watches) <- io $ either report pure =<< @@ -136,7 +135,7 @@ resultTest rt uf filepath = do mempty (const $ pure Nothing) rt - untypedFile + uf case term of Right tm -> do -- compare the the watch expression from the .u with the expr in .ur diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 3c99d4431e..ab8c262cf5 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -101,6 +101,15 @@ library Unison.Hashing.V1.Referent Unison.Hashing.V1.Term Unison.Hashing.V1.Type + Unison.Hashing.V2.Convert + Unison.Hashing.V2.DataDeclaration + Unison.Hashing.V2.LabeledDependency + Unison.Hashing.V2.Pattern + Unison.Hashing.V2.Reference + Unison.Hashing.V2.Reference.Util + Unison.Hashing.V2.Referent + Unison.Hashing.V2.Term + Unison.Hashing.V2.Type Unison.Lexer Unison.Lexer.Pos Unison.NamePrinter diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 92dc0e4dbf..bd7b8040a6 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -104,6 +104,7 @@ withEffectDeclM :: Functor f -> f (EffectDeclaration v' a') withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl +-- propose to move this code to some very feature-specific module —AI generateRecordAccessors :: (Semigroup a, Var v) => [(v, a)] From 4b859d6d91d14f2b609a5e0eb5eefbb3d9f409d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 23 Sep 2021 15:22:32 -0400 Subject: [PATCH 114/148] Add parens around let blocks, fix type parser --- parser-typechecker/src/Unison/Parser.hs | 5 + parser-typechecker/src/Unison/TermPrinter.hs | 4 +- parser-typechecker/src/Unison/TypeParser.hs | 2 +- parser-typechecker/src/Unison/TypePrinter.hs | 30 +-- unison-src/transcripts-round-trip/main.md | 25 +- .../transcripts-round-trip/main.output.md | 227 +++++++++++++----- 6 files changed, 219 insertions(+), 74 deletions(-) diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 14e4cffe37..0d57784a08 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} module Unison.Parser where @@ -53,6 +54,7 @@ import qualified Unison.Hashable as Hashable import Unison.Referent (Referent) import Unison.Reference (Reference) import Unison.Parser.Ann (Ann(..)) +import Text.Megaparsec.Error (ShowErrorComponent) debug :: Bool debug = False @@ -125,6 +127,9 @@ data Error v | FloatPattern Ann deriving (Show, Eq, Ord) +instance (Ord v, Show v) => ShowErrorComponent (Error v) where + showErrorComponent e = show e + tokenToPair :: L.Token a -> (Ann, a) tokenToPair t = (ann t, L.payload t) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index ddeb27c2c2..bdcd89b98f 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -368,7 +368,7 @@ pretty0 -> ([Pretty SyntaxText] -> Pretty SyntaxText) -> Pretty SyntaxText printLet elideUnit sc bs e im uses = - paren ((sc /= Block) && p >= 12) + paren ((sc /= Block) && p >= 3) $ letIntro $ uses [PP.lines (map printBinding bs ++ body e)] where @@ -379,7 +379,7 @@ pretty0 else prettyBinding0 n (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding letIntro = case sc of Block -> id - Normal -> \x -> (fmt S.ControlKeyword "let") `PP.hang` x + Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x -- This predicate controls which binary functions we render as infix -- operators. At the moment the policy is just to render symbolic diff --git a/parser-typechecker/src/Unison/TypeParser.hs b/parser-typechecker/src/Unison/TypeParser.hs index 6ace791bc8..7fc5e23929 100644 --- a/parser-typechecker/src/Unison/TypeParser.hs +++ b/parser-typechecker/src/Unison/TypeParser.hs @@ -72,7 +72,7 @@ type2 = do effect :: Var v => TypeP v effect = do es <- effectList - t <- valueTypeLeaf + t <- type2 pure (Type.effect1 (ann es <> ann t) es t) effectList :: Var v => TypeP v diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index cb853d16bf..c4a9af53d7 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -109,37 +109,37 @@ prettyRaw n im p tp = go n im p tp EffectfulArrows' fst rest -> case fst of Var' v | Var.name v == "()" -> - PP.parenthesizeIf (p >= 10) $ - fmt S.DelayForceChar "'" <> arrows False True rest + PP.parenthesizeIf (p >= 10) $ arrows True True rest _ -> PP.parenthesizeIf (p >= 0) $ go n im 0 fst <> arrows False False rest _ -> "error" _ -> "error" effects Nothing = mempty - effects (Just es) = PP.group $ (fmt S.AbilityBraces "{") <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}") + effects (Just es) = PP.group $ fmt S.AbilityBraces "{" <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}") + -- `first`: is this the first argument? + -- `mes`: list of effects arrow delay first mes = - (if first then mempty else PP.softbreak <> (fmt S.TypeOperator "->")) - <> (if delay then (if first then (fmt S.DelayForceChar "'") else (fmt S.DelayForceChar " '")) else mempty) + (if first then mempty else PP.softbreak <> fmt S.TypeOperator "->") + <> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty) <> effects mes - <> if (isJust mes) || (not delay) && (not first) then " " else mempty + <> if isJust mes || not delay && not first then " " else mempty - arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> (fmt S.Unit "()") + arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> fmt S.Unit "()" arrows delay first ((mes, Ref' DD.UnitRef) : rest) = - arrow delay first mes <> (parenNoGroup delay $ arrows True True rest) + arrow delay first mes <> parenNoGroup delay (arrows True True rest) arrows delay first ((mes, arg) : rest) = - arrow delay first mes - <> ( parenNoGroup (delay && (not $ null rest)) - $ go n im 0 arg - <> arrows False False rest - ) + arrow delay first mes <> parenNoGroup + (delay && not (null rest)) + (go n im 0 arg <> arrows False False rest) + arrows False False [] = mempty arrows False True [] = mempty -- not reachable arrows True _ [] = mempty -- not reachable - paren True s = PP.group $ ( fmt S.Parenthesis "(" ) <> s <> ( fmt S.Parenthesis ")" ) + paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" paren False s = PP.group s - parenNoGroup True s = ( fmt S.Parenthesis "(" ) <> s <> ( fmt S.Parenthesis ")" ) + parenNoGroup True s = fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")" parenNoGroup False s = s fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r) diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 06fca98480..803ac946d0 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -175,6 +175,29 @@ myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*T Regression test for https://github.com/unisonweb/unison/issues/1778 ```unison:hide + +structural ability base.Abort where + abort : a + +(|>) : a -> (a ->{e} b) -> {e} b +a |> f = f a + +handler : a -> Request {Abort} a -> a +handler default = cases + { a } -> a + {abort -> _} -> default + +Abort.toOptional : '{g, Abort} a -> '{g} Optional a +Abort.toOptional thunk = '(toOptional! thunk) + +Abort.toOptional! : '{g, Abort} a ->{g} (Optional a) +Abort.toOptional! thunk = toDefault! None '(Some !thunk) + +Abort.toDefault! : a -> '{g, Abort} a ->{g} a +Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle (thunk ()) with h + x = '(let abort 0) |> Abort.toOptional @@ -182,7 +205,7 @@ x = '(let ```ucm .> add -.> edit x +.> edit x base.Abort |> handler Abort.toOptional Abort.toOptional! Abort.toDefault! .> undo ``` diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index cb37d5fd6d..61e15e4e9c 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -34,15 +34,15 @@ x = 1 + 1 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #agadr8gg6g : add - 2. #bt17giel42 : builtins.mergeio + 1. #j1vrihj69n : add + 2. #m41m2ql36i : builtins.mergeio 3. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #rhf1s808fb : add - 2. #bt17giel42 : reset-root #bt17giel42 - 3. #agadr8gg6g : add - 4. #bt17giel42 : builtins.mergeio + 1. #sb99mm43ni : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #j1vrihj69n : add + 4. #m41m2ql36i : builtins.mergeio 5. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -191,19 +191,19 @@ f x = let most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #gj5agagj7s : add - 2. #bt17giel42 : reset-root #bt17giel42 - 3. #rhf1s808fb : add - 4. #bt17giel42 : reset-root #bt17giel42 - 5. #agadr8gg6g : add - 6. #bt17giel42 : builtins.mergeio + 1. #t22r3l1hsh : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #sb99mm43ni : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #j1vrihj69n : add + 6. #m41m2ql36i : builtins.mergeio 7. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -273,21 +273,21 @@ h xs = match xs with most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #3igmh2it4p : add - 2. #bt17giel42 : reset-root #bt17giel42 - 3. #gj5agagj7s : add - 4. #bt17giel42 : reset-root #bt17giel42 - 5. #rhf1s808fb : add - 6. #bt17giel42 : reset-root #bt17giel42 - 7. #agadr8gg6g : add - 8. #bt17giel42 : builtins.mergeio + 1. #ebh8598vf0 : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #t22r3l1hsh : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #sb99mm43ni : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #j1vrihj69n : add + 8. #m41m2ql36i : builtins.mergeio 9. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -314,7 +314,7 @@ Regression test for https://github.com/unisonweb/unison/issues/2392 ```unison unique ability Zonk where zonk : Nat -unique type Foo x y = +unique type Foo x y = foo : Nat -> Foo ('{Zonk} a) ('{Zonk} b) -> Nat foo n _ = n @@ -353,23 +353,23 @@ foo n _ = n most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #jsnoueu9le : add - 2. #bt17giel42 : reset-root #bt17giel42 - 3. #3igmh2it4p : add - 4. #bt17giel42 : reset-root #bt17giel42 - 5. #gj5agagj7s : add - 6. #bt17giel42 : reset-root #bt17giel42 - 7. #rhf1s808fb : add - 8. #bt17giel42 : reset-root #bt17giel42 - 9. #agadr8gg6g : add - 10. #bt17giel42 : builtins.mergeio + 1. #siglm9vcnk : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #ebh8598vf0 : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #t22r3l1hsh : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #sb99mm43ni : add + 8. #m41m2ql36i : reset-root #m41m2ql36i + 9. #j1vrihj69n : add + 10. #m41m2ql36i : builtins.mergeio 11. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -432,25 +432,25 @@ foo = most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #bt17giel42 .old` to make an old namespace + `fork #m41m2ql36i .old` to make an old namespace accessible again, - `reset-root #bt17giel42` to reset the root namespace and + `reset-root #m41m2ql36i` to reset the root namespace and its history to that of the specified namespace. - 1. #vbmanbqtlh : add - 2. #bt17giel42 : reset-root #bt17giel42 - 3. #jsnoueu9le : add - 4. #bt17giel42 : reset-root #bt17giel42 - 5. #3igmh2it4p : add - 6. #bt17giel42 : reset-root #bt17giel42 - 7. #gj5agagj7s : add - 8. #bt17giel42 : reset-root #bt17giel42 - 9. #rhf1s808fb : add - 10. #bt17giel42 : reset-root #bt17giel42 - 11. #agadr8gg6g : add - 12. #bt17giel42 : builtins.mergeio + 1. #re8lsbbg6o : add + 2. #m41m2ql36i : reset-root #m41m2ql36i + 3. #siglm9vcnk : add + 4. #m41m2ql36i : reset-root #m41m2ql36i + 5. #ebh8598vf0 : add + 6. #m41m2ql36i : reset-root #m41m2ql36i + 7. #t22r3l1hsh : add + 8. #m41m2ql36i : reset-root #m41m2ql36i + 9. #sb99mm43ni : add + 10. #m41m2ql36i : reset-root #m41m2ql36i + 11. #j1vrihj69n : add + 12. #m41m2ql36i : builtins.mergeio 13. #sjg2v58vn2 : (initial reflogged namespace) .> reset-root 2 @@ -523,3 +523,120 @@ myDoc = {{ **my text** __my text__ **MY_TEXT** ___MY__TEXT___ ~~MY~TEXT~~ **MY*T myDoc : Doc2 ``` +## Parenthesized let-block with operator + +Regression test for https://github.com/unisonweb/unison/issues/1778 + +```unison +structural ability base.Abort where + abort : a + +(|>) : a -> (a ->{e} b) -> {e} b +a |> f = f a + +handler : a -> Request {Abort} a -> a +handler default = cases + { a } -> a + {abort -> _} -> default + +Abort.toOptional : '{g, Abort} a -> '{g} Optional a +Abort.toOptional thunk = '(toOptional! thunk) + +Abort.toOptional! : '{g, Abort} a ->{g} (Optional a) +Abort.toOptional! thunk = toDefault! None '(Some !thunk) + +Abort.toDefault! : a -> '{g, Abort} a ->{g} a +Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle (thunk ()) with h + +x = '(let + abort + 0) |> Abort.toOptional +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + structural ability base.Abort + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + handler : a -> Request {Abort} a -> a + x : 'Optional Nat + |> : a -> (a ->{e} b) ->{e} b + +.> edit x base.Abort |> handler Abort.toOptional Abort.toOptional! Abort.toDefault! + + ☝️ + + I added these definitions to the top of + /Users/runar/work/unison/scratch.u + + structural ability base.Abort where abort : {base.Abort} a + + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toDefault! default thunk = + h x = Abort.toDefault! (handler default x) thunk + handle !thunk with h + + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional thunk = '(toOptional! thunk) + + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + Abort.toOptional! thunk = toDefault! None '(Some !thunk) + + handler : a -> Request {Abort} a -> a + handler default = cases + { a } -> a + {abort -> _} -> default + + x : 'Optional Nat + x = + '(let + abort + 0) |> toOptional + + (|>) : a -> (a ->{e} b) ->{e} b + a |> f = f a + + You can edit them there, then do `update` to replace the + definitions currently in this namespace. + +.> undo + + Here are the changes I undid + + Added definitions: + + 1. structural ability base.Abort + 2. base.Abort.abort : {#oup50kgmqv} a + 3. handler : a -> Request {#oup50kgmqv} a -> a + 4. Abort.toDefault! : a -> '{g, #oup50kgmqv} a ->{g} a + 5. Abort.toOptional : '{g, #oup50kgmqv} a + -> '{g} Optional a + 6. Abort.toOptional! : '{g, #oup50kgmqv} a ->{g} Optional a + 7. x : 'Optional Nat + 8. |> : a -> (a ->{e} b) ->{e} b + +``` +```ucm +.> load scratch.u + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural ability base.Abort + Abort.toDefault! : a -> '{g, Abort} a ->{g} a + Abort.toOptional : '{g, Abort} a -> '{g} Optional a + Abort.toOptional! : '{g, Abort} a ->{g} Optional a + handler : a -> Request {Abort} a -> a + x : 'Optional Nat + |> : a -> (a ->{e} b) ->{e} b + +``` From 5eeb95062b3ae8863725db2093c303439fedc1ae Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 23 Sep 2021 15:37:12 -0400 Subject: [PATCH 115/148] remove some commented code and imports --- unison-core/src/Unison/DataDeclaration.hs | 81 ----------------- unison-core/src/Unison/Term.hs | 103 +--------------------- unison-core/src/Unison/Type.hs | 3 - 3 files changed, 1 insertion(+), 186 deletions(-) diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index bd7b8040a6..dbe8513350 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -25,7 +25,6 @@ module Unison.DataDeclaration declFields, dependencies, generateRecordAccessors, - -- hashDecls, unhashComponent, mkDataDecl', mkEffectDecl', @@ -47,15 +46,11 @@ import Prelude.Extras (Show1) import qualified Unison.ABT as ABT import qualified Unison.ConstructorType as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) --- import Unison.Hash (Hash) --- import Unison.Hashable (Hashable1) --- import qualified Unison.Hashable as Hashable import qualified Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Pattern as Pattern import Unison.Reference (Reference) import qualified Unison.Reference as Reference --- import qualified Unison.Reference.Util as Reference.Util import qualified Unison.Referent as Referent import qualified Unison.Referent' as Referent' import Unison.Term (Term) @@ -235,46 +230,6 @@ data F a | Modified Modifier a deriving (Functor, Foldable, Show, Show1) --- instance Hashable1 F where --- hash1 hashCycle hash e = --- let (tag, hashed) = (Hashable.Tag, Hashable.Hashed) --- -- Note: start each layer with leading `2` byte, to avoid collisions with --- -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` --- in Hashable.accumulate $ tag 2 : case e of --- Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t] --- LetRec bindings body -> --- let (hashes, hash') = hashCycle bindings --- in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body] --- Constructors cs -> --- let (hashes, _) = hashCycle cs --- in tag 2 : map hashed hashes --- Modified m t -> --- [tag 3, Hashable.accumulateToken m, hashed $ hash t] - --- instance Hashable.Hashable Modifier where --- tokens Structural = [Hashable.Tag 0] --- tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt] - -{- - type UpDown = Up | Down - - type List a = Nil | Cons a (List a) - - type Ping p = Ping (Pong p) - type Pong p = Pong (Ping p) - - type Foo a f = Foo Int (Bar a) - type Bar a f = Bar Long (Foo a) --} - --- toABT :: Var v => DataDeclaration v () -> ABT.Term F v () --- toABT dd = ABT.tm $ Modified (modifier dd) dd' --- where --- dd' = ABT.absChain (bound dd) $ ABT.cycle --- (ABT.absChain --- (fst <$> constructors dd) --- (ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd)) - updateDependencies :: Ord v => Map Reference Reference -> Decl v a -> Decl v a updateDependencies typeUpdates decl = back $ dataDecl { constructors' = over _3 (Type.updateDependencies typeUpdates) @@ -309,42 +264,6 @@ unhashComponent m in second unhash2 <$> m' --- -- Implementation detail of `hashDecls`, works with unannotated data decls --- hashDecls0 :: (Eq v, Var v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)] --- hashDecls0 decls = --- let abts = toABT <$> decls --- ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r))) --- cs = Reference.Util.hashComponents ref abts --- in [ (v, r) | (v, (r, _)) <- Map.toList cs ] - --- -- | compute the hashes of these user defined types and update any free vars --- -- corresponding to these decls with the resulting hashes --- -- --- -- data List a = Nil | Cons a (List a) --- -- becomes something like --- -- (List, #xyz, [forall a. #xyz a, forall a. a -> (#xyz a) -> (#xyz a)]) --- -- --- -- NOTE: technical limitation, this implementation gives diff results if ctors --- -- have the same FQN as one of the types. TODO: assert this and bomb if not --- -- satisfied, or else do local mangling and unmangling to ensure this doesn't --- -- affect the hash. --- hashDecls --- :: (Eq v, Var v) --- => Map v (DataDeclaration v a) --- -> Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)] --- hashDecls decls = do --- -- todo: make sure all other external references are resolved before calling this --- let varToRef = hashDecls0 (void <$> decls) --- varToRef' = second Reference.DerivedId <$> varToRef --- decls' = bindTypes <$> decls --- bindTypes dd = dd { constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd } --- typeReferences = Map.fromList (first Name.fromVar <$> varToRef') --- -- normalize the order of the constructors based on a hash of their types --- sortCtors dd = dd { constructors' = sortOn hash3 $ constructors' dd } --- hash3 (_, _, typ) = ABT.hash typ :: Hash --- decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls' --- pure [ (v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls'] ] - amap :: (a -> a2) -> Decl v a -> Decl v a2 amap f (Left e) = Left (f <$> e) amap f (Right d) = Right (f <$> d) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 4242eb997c..b4e6e37388 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -24,9 +24,6 @@ import Prelude.Extras (Eq1(..), Show1(..)) import Text.Show import qualified Unison.ABT as ABT import qualified Unison.Blank as B --- import qualified Unison.Hash as Hash --- import Unison.Hashable (Hashable1, accumulateToken) --- import qualified Unison.Hashable as Hashable import Unison.Names3 ( Names0 ) import qualified Unison.Names3 as Names import qualified Unison.Names.ResolutionResult as Names @@ -34,7 +31,6 @@ import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Reference (Reference, pattern Builtin) import qualified Unison.Reference as Reference --- import qualified Unison.Reference.Util as ReferenceUtil import Unison.Referent (Referent, ConstructorId) import qualified Unison.Referent as Referent import Unison.Type (Type) @@ -44,8 +40,7 @@ import Unison.Util.List (multimap, validate) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var -import Unsafe.Coerce --- import Unison.Symbol (Symbol) +import Unsafe.Coerce ( unsafeCoerce ) import qualified Unison.Name as Name import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) @@ -999,32 +994,6 @@ unhashComponent m = let go e = e in second unhash1 <$> m' - --- hashComponents --- :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a) --- hashComponents = ReferenceUtil.hashComponents $ refId () - --- hashClosedTerm :: Var v => Term v a -> Reference.Id --- hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1 - --- -- The hash for a constructor --- hashConstructor' --- :: (Reference -> ConstructorId -> Term0 Symbol) -> Reference -> ConstructorId -> Reference --- hashConstructor' f r cid = --- let --- -- this is a bit circuitous, but defining everything in terms of hashComponents --- -- ensure the hashing is always done in the same way --- m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)]) --- in case toList m of --- [(r, _)] -> Reference.DerivedId r --- _ -> error "unpossible" - --- hashConstructor :: Reference -> ConstructorId -> Reference --- hashConstructor = hashConstructor' $ constructor () - --- hashRequest :: Reference -> ConstructorId -> Reference --- hashRequest = hashConstructor' $ request () - fromReferent :: Ord v => a -> Referent @@ -1035,76 +1004,6 @@ fromReferent a = \case CT.Data -> constructor a r i CT.Effect -> request a r i --- instance Var v => Hashable1 (F v a p) where --- hash1 hashCycle hash e --- = let (tag, hashed, varint) = --- (Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral) --- in --- case e of --- -- So long as `Reference.Derived` ctors are created using the same --- -- hashing function as is used here, this case ensures that references --- -- are 'transparent' wrt hash and hashing is unaffected by whether --- -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash --- -- the same. --- Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toBytes h) --- Ref (Reference.Derived h i n) -> Hashable.accumulate --- [ tag 1 --- , hashed $ Hashable.fromBytes (Hash.toBytes h) --- , Hashable.Nat i --- , Hashable.Nat n --- ] --- -- Note: start each layer with leading `1` byte, to avoid collisions --- -- with types, which start each layer with leading `0`. --- -- See `Hashable1 Type.F` --- _ -> --- Hashable.accumulate --- $ tag 1 --- : case e of --- Nat i -> [tag 64, accumulateToken i] --- Int i -> [tag 65, accumulateToken i] --- Float n -> [tag 66, Hashable.Double n] --- Boolean b -> [tag 67, accumulateToken b] --- Text t -> [tag 68, accumulateToken t] --- Char c -> [tag 69, accumulateToken c] --- Blank b -> tag 1 : case b of --- B.Blank -> [tag 0] --- B.Recorded (B.Placeholder _ s) -> --- [tag 1, Hashable.Text (Text.pack s)] --- B.Recorded (B.Resolve _ s) -> --- [tag 2, Hashable.Text (Text.pack s)] --- Ref (Reference.Builtin name) -> [tag 2, accumulateToken name] --- Ref Reference.Derived {} -> --- error "handled above, but GHC can't figure this out" --- App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)] --- Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)] --- List as -> tag 5 : varint (Sequence.length as) : map --- (hashed . hash) --- (toList as) --- Lam a -> [tag 6, hashed (hash a)] --- -- note: we use `hashCycle` to ensure result is independent of --- -- let binding order --- LetRec _ as a -> case hashCycle as of --- (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs --- -- here, order is significant, so don't use hashCycle --- Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] --- If b t f -> --- [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] --- Request r n -> [tag 10, accumulateToken r, varint n] --- Constructor r n -> [tag 12, accumulateToken r, varint n] --- Match e branches -> --- tag 13 : hashed (hash e) : concatMap h branches --- where --- h (MatchCase pat guard branch) = concat --- [ [accumulateToken pat] --- , toList (hashed . hash <$> guard) --- , [hashed (hash branch)] --- ] --- Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b] --- And x y -> [tag 16, hashed $ hash x, hashed $ hash y] --- Or x y -> [tag 17, hashed $ hash x, hashed $ hash y] --- TermLink r -> [tag 18, accumulateToken r] --- TypeLink r -> [tag 19, accumulateToken r] - -- mostly boring serialization code below ... instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 88dce8a0e9..34d1df8428 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -17,12 +17,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Prelude.Extras (Eq1(..),Show1(..),Ord1(..)) import qualified Unison.ABT as ABT --- import Unison.Hashable (Hashable1) --- import qualified Unison.Hashable as Hashable import qualified Unison.Kind as K import Unison.Reference (Reference) import qualified Unison.Reference as Reference --- import qualified Unison.Reference.Util as ReferenceUtil import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Settings as Settings From 493748925d428f318ebc39d02141c1e4315244b6 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 23 Sep 2021 15:40:16 -0400 Subject: [PATCH 116/148] formatting --- unison-core/src/Unison/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index b4e6e37388..bdc9838591 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -40,7 +40,7 @@ import Unison.Util.List (multimap, validate) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Var.RefNamed as Var -import Unsafe.Coerce ( unsafeCoerce ) +import Unsafe.Coerce (unsafeCoerce) import qualified Unison.Name as Name import qualified Unison.LabeledDependency as LD import Unison.LabeledDependency (LabeledDependency) From d387465334714a02513c0b50284912d2750c33e0 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 23 Sep 2021 15:41:33 -0400 Subject: [PATCH 117/148] remove some commented code and imports --- unison-core/src/Unison/Type.hs | 38 ---------------------------------- 1 file changed, 38 deletions(-) diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 34d1df8428..b51200a140 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -669,44 +669,6 @@ cleanup :: Var v => Type v a -> Type v a cleanup t | not Settings.cleanupTypes = t cleanup t = cleanupVars1 . cleanupAbilityLists $ t --- toReference :: (ABT.Var v, Show v) => Type v a -> Reference --- toReference (Ref' r) = r --- -- a bit of normalization - any unused type parameters aren't part of the hash --- toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body --- toReference t = Reference.Derived (ABT.hash t) 0 1 - --- toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference --- toReferenceMentions ty = --- let (vs, _) = unforall' ty --- gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty --- in Set.fromList $ toReference . gen <$> ABT.subterms ty - --- hashComponents --- :: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a) --- hashComponents = ReferenceUtil.hashComponents $ refId () - --- instance Hashable1 F where --- hash1 hashCycle hash e = --- let --- (tag, hashed) = (Hashable.Tag, Hashable.Hashed) --- -- Note: start each layer with leading `0` byte, to avoid collisions with --- -- terms, which start each layer with leading `1`. See `Hashable1 Term.F` --- in Hashable.accumulate $ tag 0 : case e of --- Ref r -> [tag 0, Hashable.accumulateToken r] --- Arrow a b -> [tag 1, hashed (hash a), hashed (hash b) ] --- App a b -> [tag 2, hashed (hash a), hashed (hash b) ] --- Ann a k -> [tag 3, hashed (hash a), Hashable.accumulateToken k ] --- -- Example: --- -- a) {Remote, Abort} (() -> {Remote} ()) should hash the same as --- -- b) {Abort, Remote} (() -> {Remote} ()) but should hash differently from --- -- c) {Remote, Abort} (() -> {Abort} ()) --- Effects es -> let --- (hs, _) = hashCycle es --- in tag 4 : map hashed hs --- Effect e t -> [tag 5, hashed (hash e), hashed (hash t)] --- Forall a -> [tag 6, hashed (hash a)] --- IntroOuter a -> [tag 7, hashed (hash a)] - instance Show a => Show (F a) where showsPrec = go where go _ (Ref r) = shows r From c0f7da86a9dbaaeba466a18b28e349f25fc8ba7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 23 Sep 2021 20:59:20 -0400 Subject: [PATCH 118/148] Run roundtrip transcripts automatically --- parser-typechecker/transcripts/Transcripts.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/parser-typechecker/transcripts/Transcripts.hs b/parser-typechecker/transcripts/Transcripts.hs index 4be359477a..712e494a56 100644 --- a/parser-typechecker/transcripts/Transcripts.hs +++ b/parser-typechecker/transcripts/Transcripts.hs @@ -109,6 +109,8 @@ test config = do $ "unison-src" "transcripts" buildTests config testBuilder $ "unison-src" "transcripts-using-base" + buildTests config testBuilder + $ "unison-src" "transcripts-round-trip" buildTests config testBuilder' $ "unison-src" "transcripts" "errors" cleanup From 2f7fb633d7456b0613213e0beb8646c7916a0b99 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 24 Sep 2021 13:55:43 -0400 Subject: [PATCH 119/148] fix up some hashing/watchkinds bugs --- parser-typechecker/src/Unison/UnisonFile.hs | 27 ++++++++++--------- .../src/Unison/UnisonFile/Names.hs | 3 ++- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index bb12e749c9..2e5f443490 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -95,31 +95,32 @@ hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId -- todo: this is confusing, right? -- currently: create a degenerate TypecheckedUnisonFile -- multiple definitions of "top-level components" non-watch vs w/ watch -typecheckedUnisonFile :: Var v +typecheckedUnisonFile :: forall v a. Var v => Map v (Reference.Id, DataDeclaration v a) -> Map v (Reference.Id, EffectDeclaration v a) -> [[(v, Term v a, Type v a)]] -> [(WatchKind, [(v, Term v a, Type v a)])] -> TypecheckedUnisonFile v a typecheckedUnisonFile datas effects tlcs watches = - file0 { hashTermsId = hashImpl file0 } + TypecheckedUnisonFileId datas effects tlcs watches hashImpl where - file0 = TypecheckedUnisonFileId datas effects tlcs watches mempty - hashImpl file = let - -- test watches are added to the codebase also - -- todo: maybe other kinds of watches too - components = topLevelComponents file - types = Map.fromList [(v,t) | (v,_,t) <- join components ] - terms0 = Map.fromList [(v,e) | (v,e,_) <- join components ] + hashImpl = let + -- |includes watches + allTerms :: [(v, Term v a, Type v a)] + allTerms = join tlcs ++ join (snd <$> watches) + types :: Map v (Type v a) + types = Map.fromList [(v,t) | (v,_,t) <- allTerms ] + watchKinds :: Map v (Maybe WatchKind) watchKinds = Map.fromList $ - [(v,Nothing) | (v,_e,_t) <- join $ topLevelComponents' file] - ++ [(v, Just wk) | (wk, terms) <- watches, (v, _e, _t) <- terms ] - hcs = Hashing.hashTermComponents terms0 + [(v,Nothing) | (v,_e,_t) <- join tlcs] + ++ [(v, Just wk) | (wk, wkTerms) <- watches, (v, _e, _t) <- wkTerms ] + -- good spot incorporate type of term into its hash, if not already present as an annotation (#2276) + hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, e, _t) -> (v, e)) <$> allTerms in Map.fromList [ (v, (r, wk, e, t)) | (v, (r, e)) <- Map.toList hcs , Just t <- [Map.lookup v types] - , Just wk <- [Map.lookup v watchKinds] ] + , wk <- [Map.findWithDefault (error $ show v ++ " missing from watchKinds") v watchKinds]] lookupDecl :: Ord v => v -> TypecheckedUnisonFile v a -> Maybe (Reference.Id, DD.Decl v a) diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index fff4ba981f..ef62ce8888 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -27,6 +27,7 @@ import Unison.UnisonFile.Error (Error (DupDataAndAbility, UnknownType)) import Unison.UnisonFile.Type (TypecheckedUnisonFile (TypecheckedUnisonFileId), UnisonFile (UnisonFileId)) import qualified Unison.Util.Relation as Relation import Unison.Var (Var) +import qualified Unison.WatchKind as WK toNames :: Var v => UnisonFile v a -> Names0 toNames uf = datas <> effects @@ -38,7 +39,7 @@ typecheckedToNames0 :: Var v => TypecheckedUnisonFile v a -> Names0 typecheckedToNames0 uf = Names.names0 (terms <> ctors) types where terms = Relation.fromList [ (Name.fromVar v, Referent.Ref r) - | (v, (r, _, _, _)) <- Map.toList $ UF.hashTerms uf ] + | (v, (r, wk, _, _)) <- Map.toList $ UF.hashTerms uf, wk == Nothing || wk == Just WK.TestWatch ] types = Relation.fromList [ (Name.fromVar v, r) | (v, r) <- Map.toList $ fmap fst (UF.dataDeclarations' uf) From 61495a76b3794bffc58dcd88a00a6c0169cc7419 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 24 Sep 2021 14:13:08 -0400 Subject: [PATCH 120/148] delete some extra junk --- parser-typechecker/src/Unison/Codebase/Runtime.hs | 4 ---- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 2 -- parser-typechecker/src/Unison/Codebase/Type.hs | 3 --- 3 files changed, 9 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index 5671a5245b..de59541cbb 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -134,10 +134,6 @@ evaluateTerm' codeLookup cache ppe rt tm = do Just r -> pure (Right r) Nothing -> do let - -- v = Var.nameds "result" - -- k = WK.RegularWatch - -- term = tm - -- tp = mainType rt tuf = UF.typecheckedUnisonFile mempty mempty mempty [(WK.RegularWatch, [(Var.nameds "result", tm, mempty <$> mainType rt)])] r <- evaluateWatches (void codeLookup) ppe cache rt (void tuf) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 35d4ad1edf..46dc0f0abd 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -742,8 +742,6 @@ sqliteCodebase debugName root = do (Cache.applyDefined declCache getTypeDeclaration) putTerm putTypeDeclaration - (runDB conn . getCycleLen "Codebase.getTermComponentLength") - (runDB conn . getCycleLen "Codebase.getDeclComponentLength") (getRootBranch rootBranchCache) (putRootBranch rootBranchCache) (rootBranchUpdates rootBranchCache) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 6a36beb38e..01b6600c6b 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -22,7 +22,6 @@ import Unison.Type (Type) import qualified Unison.WatchKind as WK import Unison.Codebase.GitError (GitProtocolError, GitCodebaseError) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError) -import Unison.Hash (Hash) type SyncToDir m = CodebasePath -> -- dest codebase @@ -39,8 +38,6 @@ data Codebase m v a = Codebase getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), putTerm :: Reference.Id -> Term v a -> Type v a -> m (), putTypeDeclaration :: Reference.Id -> Decl v a -> m (), - getTermComponentLength :: Hash -> m Reference.Size, - getDeclComponentLength :: Hash -> m Reference.Size, getRootBranch :: m (Either GetRootBranchError (Branch m)), putRootBranch :: Branch m -> m (), rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), From 2a27e55c6f59f9be55a8fe59851833788310d8c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Fri, 24 Sep 2021 14:27:00 -0400 Subject: [PATCH 121/148] Determine if a delayed term is a block --- parser-typechecker/src/Unison/TermPrinter.hs | 31 +++++++++++++------ .../tests/Unison/Test/TermPrinter.hs | 10 +++--- parser-typechecker/transcripts/Transcripts.hs | 2 -- unison-core/src/Unison/Term.hs | 1 - .../transcripts-round-trip/main.output.md | 2 +- 5 files changed, 28 insertions(+), 18 deletions(-) diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index bdcd89b98f..b8c5bdc511 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -87,20 +87,20 @@ data BlockContext -- This ABT node is at the top level of a TermParser.block. = Block | Normal - deriving (Eq) + deriving (Eq, Show) data InfixContext -- This ABT node is an infix operator being used in infix position. = Infix | NonInfix - deriving (Eq) + deriving (Eq, Show) data DocLiteralContext -- We won't try and render this ABT node or anything under it as a [: @Doc literal :] = NoDoc -- We'll keep checking as we recurse down | MaybeDoc - deriving (Eq) + deriving (Eq, Show) {- Explanation of precedence handling @@ -238,9 +238,13 @@ pretty0 pblock tm = let (im', uses) = calcImports im tm in uses $ [pretty0 n (ac 0 Block im' doc) tm] App' x (Constructor' DD.UnitRef 0) -> - paren (p >= 11) $ (fmt S.DelayForceChar $ l "!") <> pretty0 n (ac 11 Normal im doc) x - Delay' x -> - paren (p >= 11) $ (fmt S.DelayForceChar $ l "'") <> pretty0 n (ac 11 Normal im doc) x + paren (p >= 11 || isBlock x && p >= 3) $ + fmt S.DelayForceChar (l "!") + <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x + Delay' x -> + paren (p >= 11 || isBlock x && p >= 3) $ + fmt S.DelayForceChar (l "'") + <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x List' xs -> PP.group $ (fmt S.DelimiterChar $ l "[") <> optSpace <> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace) @@ -368,7 +372,7 @@ pretty0 -> ([Pretty SyntaxText] -> Pretty SyntaxText) -> Pretty SyntaxText printLet elideUnit sc bs e im uses = - paren ((sc /= Block) && p >= 3) + paren ((sc /= Block) && p >= 12) $ letIntro $ uses [PP.lines (map printBinding bs ++ body e)] where @@ -379,7 +383,7 @@ pretty0 else prettyBinding0 n (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding letIntro = case sc of Block -> id - Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x + Normal -> \x -> (fmt S.ControlKeyword "let") `PP.hang` x -- This predicate controls which binary functions we render as infix -- operators. At the moment the policy is just to render symbolic @@ -421,7 +425,7 @@ pretty0 _ -> undefined ps = join $ [ r a f | (a, f) <- reverse xs ] r a f = - [ pretty0 n (ac 3 Normal im doc) a + [ pretty0 n (ac (if isBlock a then 12 else 3) Normal im doc) a , pretty0 n (AmbientContext 10 Normal Infix im doc False) f ] @@ -1176,6 +1180,15 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)] Pattern.Unbound _ -> False isDestructuringBind _ _ = False +isBlock :: Ord v => Term2 vt at ap v a -> Bool +isBlock tm = + case tm of + If' _ _ _ -> True + Handle' _ _ -> True + Match' _ _ -> True + LetBlock _ _ -> True + _ -> False + pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body)) -- Collects nested let/let rec blocks into one minimally nested block. diff --git a/parser-typechecker/tests/Unison/Test/TermPrinter.hs b/parser-typechecker/tests/Unison/Test/TermPrinter.hs index 66f21a5b86..e51bc37660 100644 --- a/parser-typechecker/tests/Unison/Test/TermPrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TermPrinter.hs @@ -344,13 +344,13 @@ test = scope "termprinter" $ tests , tc "!f a" , tcDiff "f () a ()" "!(!f a)" , tcDiff "f a b ()" "!(f a b)" - , tcDiff "!f ()" "!(!f)" - , tc "!(!foo)" + , tcDiff "!f ()" "!!f" + , tcDiff "!(!foo)" "!!foo" , tc "'bar" , tc "'(bar a b)" - , tc "'('bar)" - , tc "!('bar)" - , tc "'(!foo)" + , tcDiff "'('bar)" "''bar" + , tcDiff "!('bar)" "!'bar" + , tcDiff "'(!foo)" "'!foo" , tc "x -> '(y -> 'z)" , tc "'(x -> '(y -> z))" , tc "(\"a\", 2)" diff --git a/parser-typechecker/transcripts/Transcripts.hs b/parser-typechecker/transcripts/Transcripts.hs index 712e494a56..4be359477a 100644 --- a/parser-typechecker/transcripts/Transcripts.hs +++ b/parser-typechecker/transcripts/Transcripts.hs @@ -109,8 +109,6 @@ test config = do $ "unison-src" "transcripts" buildTests config testBuilder $ "unison-src" "transcripts-using-base" - buildTests config testBuilder - $ "unison-src" "transcripts-round-trip" buildTests config testBuilder' $ "unison-src" "transcripts" "errors" cleanup diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 765f8b991d..77cfd96a6b 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -443,7 +443,6 @@ unDelay tm = case ABT.out tm of | Set.notMember v (ABT.freeVars body) -> Just body _ -> Nothing - pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body)))) pattern LamsNamed' vs body <- (unLams' -> Just (vs, body)) pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body)) diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 61e15e4e9c..31b68ffe0c 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -595,7 +595,7 @@ x = '(let x : 'Optional Nat x = - '(let + ('let abort 0) |> toOptional From 79b2d90f2155891fd51c5b4303423d93d98b76f2 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 24 Sep 2021 14:42:25 -0400 Subject: [PATCH 122/148] clear old comment --- parser-typechecker/src/Unison/UnisonFile.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 2e5f443490..9f03a64144 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -92,9 +92,6 @@ effectDeclarations' = fmap (first Reference.DerivedId) . effectDeclarationsId' hashTerms :: TypecheckedUnisonFile v a -> Map v (Reference, Maybe WatchKind, Term v a, Type v a) hashTerms = fmap (over _1 Reference.DerivedId) . hashTermsId --- todo: this is confusing, right? --- currently: create a degenerate TypecheckedUnisonFile --- multiple definitions of "top-level components" non-watch vs w/ watch typecheckedUnisonFile :: forall v a. Var v => Map v (Reference.Id, DataDeclaration v a) -> Map v (Reference.Id, EffectDeclaration v a) From 6900889c3f71497061f67c7a4d2f12071625cc3f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 24 Sep 2021 14:49:25 -0400 Subject: [PATCH 123/148] cleanup --- .../src/Unison/Hashing/V1/DataDeclaration.hs | 17 +---------------- .../src/Unison/Hashing/V1/LabeledDependency.hs | 2 +- .../src/Unison/Hashing/V1/Pattern.hs | 9 --------- .../src/Unison/Hashing/V1/Reference.hs | 2 +- .../src/Unison/Hashing/V2/DataDeclaration.hs | 12 ------------ .../src/Unison/Hashing/V2/LabeledDependency.hs | 2 +- .../src/Unison/Hashing/V2/Pattern.hs | 9 --------- .../src/Unison/Hashing/V2/Reference.hs | 2 +- .../src/Unison/Hashing/V2/Reference/Util.hs | 2 -- .../src/Unison/Hashing/V2/Referent.hs | 3 --- 10 files changed, 5 insertions(+), 55 deletions(-) diff --git a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs index 78d268f11b..f153f8513c 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/DataDeclaration.hs @@ -14,7 +14,6 @@ module Unison.Hashing.V1.DataDeclaration asDataDecl, constructorType, constructorTypes, - -- declConstructorReferents, declDependencies, dependencies, bindReferences, @@ -27,7 +26,6 @@ import Data.Bifunctor (first, second) import qualified Data.Map as Map import qualified Data.Set as Set import Prelude.Extras (Show1) -import Unison.Var (Var) import qualified Unison.ABT as ABT import qualified Unison.ConstructorType as CT import Unison.Hash (Hash) @@ -41,10 +39,8 @@ import qualified Unison.Hashing.V1.Type as Type import qualified Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names import Unison.Prelude --- import qualified Unison.Referent as Referent --- import qualified Unison.Referent' as Referent' +import Unison.Var (Var) import Prelude hiding (cycle) - type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a) data DeclOrBuiltin v a @@ -85,17 +81,6 @@ constructorTypes = (snd <$>) . constructors constructors :: DataDeclaration v a -> [(v, Type v a)] constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] --- -- This function is unsound, since the `rid` and the `decl` have to match. --- -- It should probably be hashed directly from the Decl, once we have a --- -- reliable way of doing that. —AI --- declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] --- declConstructorReferents rid decl = --- [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] --- where ct = constructorType decl - --- constructorIds :: DataDeclaration v a -> [Int] --- constructorIds dd = [0 .. length (constructors dd) - 1] - dependencies :: Ord v => DataDeclaration v a -> Set Reference dependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) diff --git a/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs index 26119dfa4f..8453208239 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/LabeledDependency.hs @@ -53,4 +53,4 @@ toReference :: LabeledDependency -> Either Reference Reference toReference = \case X (Left r) -> Left r X (Right (Ref r)) -> Right r - X (Right (Con r _ _)) -> Left r \ No newline at end of file + X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs index 93077212c3..8647a1cb91 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Pattern.hs @@ -7,8 +7,6 @@ import Unison.Prelude import Data.Foldable as Foldable hiding (foldMap') import Data.List (intercalate) import qualified Data.Set as Set --- import Unison.LabeledDependency (LabeledDependency) --- import qualified Unison.LabeledDependency as LD import Unison.Hashing.V1.Reference (Reference) import qualified Unison.Hashing.V1.Type as Type import qualified Unison.Hashable as H @@ -156,10 +154,3 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e Text _ _ -> [literalType Type.textRef] Char _ _ -> [literalType Type.charRef] ) - --- labeledDependencies :: Pattern loc -> Set LabeledDependency --- labeledDependencies = generalizedDependencies LD.typeRef --- LD.dataConstructor --- LD.typeRef --- LD.effectConstructor --- LD.typeRef \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V1/Reference.hs b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs index 0bcdee547f..0202b44f5d 100644 --- a/parser-typechecker/src/Unison/Hashing/V1/Reference.hs +++ b/parser-typechecker/src/Unison/Hashing/V1/Reference.hs @@ -189,4 +189,4 @@ instance Hashable.Hashable Reference where -- | Two references mustn't differ in cycle length only. instance Eq Id where x == y = compare x y == EQ -instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 \ No newline at end of file +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs index 1867adba70..eab303bcb6 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs @@ -14,7 +14,6 @@ module Unison.Hashing.V2.DataDeclaration asDataDecl, constructorType, constructorTypes, - -- declConstructorReferents, declDependencies, dependencies, bindReferences, @@ -85,17 +84,6 @@ constructorTypes = (snd <$>) . constructors constructors :: DataDeclaration v a -> [(v, Type v a)] constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors] --- -- This function is unsound, since the `rid` and the `decl` have to match. --- -- It should probably be hashed directly from the Decl, once we have a --- -- reliable way of doing that. —AI --- declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id] --- declConstructorReferents rid decl = --- [ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ] --- where ct = constructorType decl - --- constructorIds :: DataDeclaration v a -> [Int] --- constructorIds dd = [0 .. length (constructors dd) - 1] - dependencies :: Ord v => DataDeclaration v a -> Set Reference dependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) diff --git a/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs index 5bbdbe3730..8a00577122 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs @@ -53,4 +53,4 @@ toReference :: LabeledDependency -> Either Reference Reference toReference = \case X (Left r) -> Left r X (Right (Ref r)) -> Right r - X (Right (Con r _ _)) -> Left r \ No newline at end of file + X (Right (Con r _ _)) -> Left r diff --git a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs index 6ced5fb8c5..8a766f8b17 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs @@ -7,8 +7,6 @@ import Unison.Prelude import Data.Foldable as Foldable hiding (foldMap') import Data.List (intercalate) import qualified Data.Set as Set --- import Unison.LabeledDependency (LabeledDependency) --- import qualified Unison.LabeledDependency as LD import Unison.Hashing.V2.Reference (Reference) import qualified Unison.Hashing.V2.Type as Type import qualified Unison.Hashable as H @@ -156,10 +154,3 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e Text _ _ -> [literalType Type.textRef] Char _ _ -> [literalType Type.charRef] ) - --- labeledDependencies :: Pattern loc -> Set LabeledDependency --- labeledDependencies = generalizedDependencies LD.typeRef --- LD.dataConstructor --- LD.typeRef --- LD.effectConstructor --- LD.typeRef \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs index b1ff2cf99c..75e9641bea 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference.hs @@ -189,4 +189,4 @@ instance Hashable.Hashable Reference where -- | Two references mustn't differ in cycle length only. instance Eq Id where x == y = compare x y == EQ -instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 \ No newline at end of file +instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2 diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs index 77b02efb5c..817da14efe 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs @@ -17,5 +17,3 @@ hashComponents embedRef tms = Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ] where cs = Reference.components $ ABT.hashComponents ref tms ref h i n = embedRef (Reference.Id h i n) - - diff --git a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs index 04531bcaff..af9a00fc11 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Referent.hs @@ -33,9 +33,6 @@ pattern Con r i t = Con' r i t -- | Cannot be a builtin. type Id = Referent' R.Id --- referentToTerm moved to Term.fromReferent --- termToReferent moved to Term.toReferent - -- todo: move these to ShortHash module toShortHash :: Referent -> ShortHash toShortHash = \case From 96ef4dc93808ac3ef7da9f2247e32f0a8d21b5fb Mon Sep 17 00:00:00 2001 From: rlmark Date: Fri, 24 Sep 2021 12:04:34 -0700 Subject: [PATCH 124/148] spike of adding some notion of linking input to output --- .../src/Unison/Codebase/Editor/Command.hs | 10 +- .../Unison/Codebase/Editor/HandleCommand.hs | 18 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +- .../src/Unison/Codebase/Editor/Input.hs | 287 ++++---- .../src/Unison/Codebase/Editor/InputOutput.hs | 484 +++++++++++++ .../src/Unison/Codebase/Editor/Output.hs | 655 +++++++++--------- parser-typechecker/src/Unison/CommandLine.hs | 2 +- .../src/Unison/CommandLine/InputPattern.hs | 2 +- .../src/Unison/CommandLine/Main.hs | 10 +- .../src/Unison/CommandLine/OutputMessages.hs | 16 +- .../src/Unison/CommandLine/Welcome.hs | 107 +-- .../Unison/CommandLine/WelcomeInputQueue.hs | 134 ++++ 12 files changed, 1186 insertions(+), 543 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs create mode 100644 parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index dc3889a687..1a260dd953 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -26,7 +26,8 @@ import Unison.Server.Backend ( DefinitionResults import Data.Configurator.Types ( Configured ) import qualified Data.Map as Map -import Unison.Codebase.Editor.Output +-- import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.InputOutput import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Branch ( Branch ) @@ -64,8 +65,8 @@ import qualified Unison.WatchKind as WK import Unison.Codebase.Type (GitError) type AmbientAbilities v = [Type v Ann] -type SourceName = Text -type Source = Text +-- type SourceName = Text +-- type Source = Text type LexedSource = (Text, [L.Token L.Lexeme]) data LoadSourceResult = InvalidSourceNameError @@ -105,6 +106,8 @@ data Command m i v a where Input :: Command m i v i + InputWithOutput :: Command m i v i -> Output v -> Command m i v i + -- Presents some output to the user Notify :: Output v -> Command m i v () NotifyNumbered :: NumberedOutput v -> Command m i v NumberedArgs @@ -253,6 +256,7 @@ commandName = \case UI -> "UI" ConfigLookup{} -> "ConfigLookup" Input -> "Input" + InputWithOutput{} -> "Input" Notify{} -> "Notify" NotifyNumbered{} -> "NotifyNumbered" AddDefsToCodebase{} -> "AddDefsToCodebase" diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index cd8e82fdda..d542436906 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -9,7 +9,7 @@ module Unison.Codebase.Editor.HandleCommand where import Unison.Prelude -import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.InputOutput import Unison.Codebase.Editor.Command import qualified Unison.Builtin as B @@ -82,10 +82,10 @@ commandLine :: forall i v a gen . (Var v, Random.DRG gen) => Config - -> IO i + -> IO i -- RLM: await input -> (Branch IO -> IO ()) - -> Runtime v - -> (Output v -> IO ()) + -> Runtime v + -> (Output v -> IO ()) -- RLM: notify -> (NumberedOutput v -> IO NumberedArgs) -> (SourceName -> IO LoadSourceResult) -> Codebase IO v Ann @@ -104,9 +104,17 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour case serverBaseUrl of Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url) Nothing -> lift (return ()) + InputWithOutput input output -> do + -- RLM: not sure how exactly this is gonna work + let + fst = go input + snd = lift $ notifyUser output + + fst >>= snd + -- lift awaitInput >> \_ -> lift $ notifyUser output Input -> lift awaitInput Notify output -> lift $ notifyUser output - NotifyNumbered output -> lift $ notifyNumbered output + NotifyNumbered output -> lift $ notifyNumbered output ConfigLookup name -> lift $ Config.lookup config name LoadSource sourcePath -> lift $ loadSource sourcePath diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 1256b6509f..f3ea9c5c97 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -28,9 +28,9 @@ import Unison.Server.Backend (ShallowListEntry(..), TermEntry(..), TypeEntry(..) import qualified Unison.Codebase.MainTerm as MainTerm import Unison.Codebase.Editor.Command as Command import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.InputOutput import Unison.Codebase.Editor.DisplayObject -import qualified Unison.Codebase.Editor.Output as Output +import qualified Unison.Codebase.Editor.InputOutput as Output import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) import qualified Unison.Codebase.Editor.SlurpResult as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..)) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 8f51773f61..d1fb86a22d 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -1,153 +1,152 @@ module Unison.Codebase.Editor.Input - ( Input(..) - , Event(..) - , OutputLocation(..) - , PatchPath - , BranchId, parseBranchId - , HashOrHQSplit' - ) where -import Unison.Prelude +where -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Branch.Merge as Branch -import qualified Unison.HashQualified as HQ -import qualified Unison.HashQualified' as HQ' -import Unison.Codebase.Path ( Path' ) -import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Path.Parse as Path -import Unison.Codebase.Editor.RemoteRepo -import Unison.ShortHash (ShortHash) -import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.ShortBranchHash as SBH -import Unison.Codebase.SyncMode ( SyncMode ) -import Unison.Name ( Name ) -import Unison.NameSegment ( NameSegment ) +-- import Unison.Prelude -import qualified Data.Text as Text +-- import qualified Unison.Codebase.Branch as Branch +-- import qualified Unison.Codebase.Branch.Merge as Branch +-- import qualified Unison.HashQualified as HQ +-- import qualified Unison.HashQualified' as HQ' +-- import Unison.Codebase.Path ( Path' ) +-- import qualified Unison.Codebase.Path as Path +-- import qualified Unison.Codebase.Path.Parse as Path +-- import Unison.Codebase.Editor.RemoteRepo +-- import Unison.ShortHash (ShortHash) +-- import Unison.Codebase.ShortBranchHash (ShortBranchHash) +-- import qualified Unison.Codebase.ShortBranchHash as SBH +-- import Unison.Codebase.SyncMode ( SyncMode ) +-- import Unison.Name ( Name ) +-- import Unison.NameSegment ( NameSegment ) -data Event - = UnisonFileChanged SourceName Source - | IncomingRootBranch (Set Branch.Hash) +-- import qualified Data.Text as Text +-- import Unison.Codebase.Editor.InputOutput +-- import Unison.Codebase.Editor.Output -- :( -type Source = Text -- "id x = x\nconst a b = a" -type SourceName = Text -- "foo.u" or "buffer 7" -type PatchPath = Path.Split' -type BranchId = Either ShortBranchHash Path' -type HashOrHQSplit' = Either ShortHash Path.HQSplit' +-- data Event +-- = UnisonFileChanged SourceName Source +-- | IncomingRootBranch (Set Branch.Hash) -parseBranchId :: String -> Either String BranchId -parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of - Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> pure $ Left h -parseBranchId s = Right <$> Path.parsePath' s +-- type PatchPath = Path.Split' +-- type Source = Text -- "id x = x\nconst a b = a" +-- type SourceName = Text -- "foo.u" or "buffer 7" +-- type BranchId = Either ShortBranchHash Path' +-- type HashOrHQSplit' = Either ShortHash Path.HQSplit' -data Input - -- names stuff: - -- directory ops - -- `Link` must describe a repo and a source path within that repo. - -- clone w/o merge, error if would clobber - = ForkLocalBranchI (Either ShortBranchHash Path') Path' - -- merge first causal into destination - | MergeLocalBranchI Path' Path' Branch.MergeMode - | PreviewMergeLocalBranchI Path' Path' - | DiffNamespaceI Path' Path' -- old new - | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode - | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode - | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace - | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' - | ResetRootI (Either ShortBranchHash Path') - -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? - -- Does it make sense to fork from not-the-root of a Github repo? - -- change directory - | SwitchBranchI Path' - | UpI - | PopBranchI - -- > names foo - -- > names foo.bar - -- > names .foo.bar - -- > names .foo.bar#asdflkjsdf - -- > names #sdflkjsdfhsdf - | NamesI (HQ.HashQualified Name) - | AliasTermI HashOrHQSplit' Path.Split' - | AliasTypeI HashOrHQSplit' Path.Split' - | AliasManyI [Path.HQSplit] Path' - -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. - | MoveTermI Path.HQSplit' Path.Split' - | MoveTypeI Path.HQSplit' Path.Split' - | MoveBranchI (Maybe Path.Split') Path.Split' - | MovePatchI Path.Split' Path.Split' - | CopyPatchI Path.Split' Path.Split' - -- delete = unname - | DeleteI Path.HQSplit' - | DeleteTermI Path.HQSplit' - | DeleteTypeI Path.HQSplit' - | DeleteBranchI (Maybe Path.Split') - | DeletePatchI Path.Split' - -- resolving naming conflicts within `branchpath` - -- Add the specified name after deleting all others for a given reference - -- within a given branch. - | ResolveTermNameI Path.HQSplit' - | ResolveTypeNameI Path.HQSplit' - -- edits stuff: - | LoadI (Maybe FilePath) - | 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' - | ReplaceI (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 - | HistoryI (Maybe Int) (Maybe Int) BranchId - -- execute an IO thunk - | ExecuteI String - -- execute an IO [Result] - | IOTestI (HQ.HashQualified Name) - | TestI Bool Bool -- TestI showSuccesses showFailures - -- metadata - -- `link metadata definitions` (adds metadata to all of `definitions`) - | LinkI (HQ.HashQualified Name) [Path.HQSplit'] - -- `unlink metadata definitions` (removes metadata from all of `definitions`) - | UnlinkI (HQ.HashQualified Name) [Path.HQSplit'] - -- links from - | LinksI Path.HQSplit' (Maybe String) - | CreateAuthorI NameSegment {- identifier -} Text {- name -} - | DisplayI OutputLocation (HQ.HashQualified Name) - | DocsI Path.HQSplit' - -- other - | SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query - | FindShallowI Path' - | FindPatchI - | ShowDefinitionI OutputLocation [HQ.HashQualified Name] - | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] - | ShowReflogI - | UpdateBuiltinsI - | MergeBuiltinsI - | MergeIOBuiltinsI - | ListDependenciesI (HQ.HashQualified Name) - | ListDependentsI (HQ.HashQualified Name) - | DebugNumberedArgsI - | DebugTypecheckedUnisonFileI - | DebugDumpNamespacesI - | DebugDumpNamespaceSimpleI - | DebugClearWatchI - | QuitI - | UiI - deriving (Eq, Show) +-- parseBranchId :: String -> Either String BranchId +-- parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of +-- Nothing -> Left "Invalid hash, expected a base32hex string." +-- Just h -> pure $ Left h +-- parseBranchId s = Right <$> Path.parsePath' s --- Some commands, like `view`, can dump output to either console or a file. -data OutputLocation - = ConsoleLocation - | LatestFileLocation - | FileLocation FilePath - -- ClipboardLocation - deriving (Eq, Show) +-- data Input +-- -- names stuff: +-- -- directory ops +-- -- `Link` must describe a repo and a source path within that repo. +-- -- clone w/o merge, error if would clobber +-- = ForkLocalBranchI (Either ShortBranchHash Path') Path' +-- -- pairs onboarding input with desired output response +-- | RespondToInput Input Output -- CYCLE +-- -- merge first causal into destination +-- | MergeLocalBranchI Path' Path' Branch.MergeMode +-- | PreviewMergeLocalBranchI Path' Path' +-- | DiffNamespaceI Path' Path' -- old new +-- | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode +-- | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode +-- | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace +-- | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' +-- | ResetRootI (Either ShortBranchHash Path') +-- -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? +-- -- Does it make sense to fork from not-the-root of a Github repo? +-- -- change directory +-- | SwitchBranchI Path' +-- | UpI +-- | PopBranchI +-- -- > names foo +-- -- > names foo.bar +-- -- > names .foo.bar +-- -- > names .foo.bar#asdflkjsdf +-- -- > names #sdflkjsdfhsdf +-- | NamesI (HQ.HashQualified Name) +-- | AliasTermI HashOrHQSplit' Path.Split' +-- | AliasTypeI HashOrHQSplit' Path.Split' +-- | AliasManyI [Path.HQSplit] Path' +-- -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. +-- | MoveTermI Path.HQSplit' Path.Split' +-- | MoveTypeI Path.HQSplit' Path.Split' +-- | MoveBranchI (Maybe Path.Split') Path.Split' +-- | MovePatchI Path.Split' Path.Split' +-- | CopyPatchI Path.Split' Path.Split' +-- -- delete = unname +-- | DeleteI Path.HQSplit' +-- | DeleteTermI Path.HQSplit' +-- | DeleteTypeI Path.HQSplit' +-- | DeleteBranchI (Maybe Path.Split') +-- | DeletePatchI Path.Split' +-- -- resolving naming conflicts within `branchpath` +-- -- Add the specified name after deleting all others for a given reference +-- -- within a given branch. +-- | ResolveTermNameI Path.HQSplit' +-- | ResolveTypeNameI Path.HQSplit' +-- -- edits stuff: +-- | LoadI (Maybe FilePath) +-- | 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' +-- | ReplaceI (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 +-- | HistoryI (Maybe Int) (Maybe Int) BranchId +-- -- execute an IO thunk +-- | ExecuteI String +-- -- execute an IO [Result] +-- | IOTestI (HQ.HashQualified Name) +-- | TestI Bool Bool -- TestI showSuccesses showFailures +-- -- metadata +-- -- `link metadata definitions` (adds metadata to all of `definitions`) +-- | LinkI (HQ.HashQualified Name) [Path.HQSplit'] +-- -- `unlink metadata definitions` (removes metadata from all of `definitions`) +-- | UnlinkI (HQ.HashQualified Name) [Path.HQSplit'] +-- -- links from +-- | LinksI Path.HQSplit' (Maybe String) +-- | CreateAuthorI NameSegment {- identifier -} Text {- name -} +-- | DisplayI OutputLocation (HQ.HashQualified Name) +-- | DocsI Path.HQSplit' +-- -- other +-- | SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query +-- | FindShallowI Path' +-- | FindPatchI +-- | ShowDefinitionI OutputLocation [HQ.HashQualified Name] +-- | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] +-- | ShowReflogI +-- | UpdateBuiltinsI +-- | MergeBuiltinsI +-- | MergeIOBuiltinsI +-- | ListDependenciesI (HQ.HashQualified Name) +-- | ListDependentsI (HQ.HashQualified Name) +-- | DebugNumberedArgsI +-- | DebugTypecheckedUnisonFileI +-- | DebugDumpNamespacesI +-- | DebugDumpNamespaceSimpleI +-- | DebugClearWatchI +-- | QuitI +-- | UiI +-- deriving (Eq, Show) + +-- -- Some commands, like `view`, can dump output to either console or a file. +-- data OutputLocation +-- = ConsoleLocation +-- | LatestFileLocation +-- | FileLocation FilePath +-- -- ClipboardLocation +-- deriving (Eq, Show) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs b/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs new file mode 100644 index 0000000000..a42ea9a641 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs @@ -0,0 +1,484 @@ + +{-# LANGUAGE StandaloneDeriving #-} -- RLM: Not sure exactly + + +module Unison.Codebase.Editor.InputOutput +where + +import Unison.Prelude + +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Merge as Branch +import qualified Unison.HashQualified as HQ +import qualified Unison.HashQualified' as HQ' +import Unison.Codebase.Path ( Path' ) +import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path +import Unison.Codebase.Editor.RemoteRepo +import Unison.ShortHash (ShortHash) +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import qualified Unison.Codebase.ShortBranchHash as SBH +import Unison.Codebase.SyncMode ( SyncMode ) +import Unison.Name ( Name ) +import Unison.NameSegment ( NameSegment ) + +import qualified Data.Text as Text + + +--- + +import Unison.Server.Backend (ShallowListEntry(..)) +import Unison.Codebase (GetRootBranchError) +import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) +import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Type (GitError) +import Unison.Names2 ( Names ) +import Unison.Parser.Ann (Ann) +import qualified Unison.Reference as Reference +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) +import Unison.DataDeclaration ( Decl ) +import Unison.Util.Relation (Relation) +import qualified Unison.Codebase.Editor.SlurpResult as SR +import qualified Unison.Codebase.Metadata as Metadata +import qualified Unison.Codebase.Runtime as Runtime +import qualified Unison.Parser as Parser +import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.Typechecker.Context as Context +import qualified Unison.UnisonFile as UF +import qualified Unison.Util.Pretty as P +import Unison.Codebase.Editor.DisplayObject (DisplayObject) +import qualified Unison.Codebase.Editor.TodoOutput as TO +import Unison.Server.SearchResult' (SearchResult') +import Unison.Term (Term) +import Unison.Type (Type) +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Names3 as Names +import qualified Data.Set as Set +import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) +import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.WatchKind as WK + +-- EVERYTHING FROM INPUT +data Event + = UnisonFileChanged SourceName Source + | IncomingRootBranch (Set Branch.Hash) + +type Source = Text -- "id x = x\nconst a b = a" +type SourceName = Text -- "foo.u" or "buffer 7" +type BranchId = Either ShortBranchHash Path' +type HashOrHQSplit' = Either ShortHash Path.HQSplit' +type PatchPath = Path.Split' + +parseBranchId :: String -> Either String BranchId +parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of + Nothing -> Left "Invalid hash, expected a base32hex string." + Just h -> pure $ Left h +parseBranchId s = Right <$> Path.parsePath' s + +data Input + -- names stuff: + -- directory ops + -- `Link` must describe a repo and a source path within that repo. + -- clone w/o merge, error if would clobber + = ForkLocalBranchI (Either ShortBranchHash Path') Path' + -- pairs onboarding input with desired output response + -- | RespondToInput Input (Output String) -- RLM note: cycle happens here, also what is this type param? I chose an arbitrary type here and I know it shouldnt be a string. + | RespondToInput Input OutputSimple -- RLM note: cycle happens here, also what is this type param? I chose an arbitrary type here and I know it shouldnt be a string. + -- merge first causal into destination + | MergeLocalBranchI Path' Path' Branch.MergeMode + | PreviewMergeLocalBranchI Path' Path' + | DiffNamespaceI Path' Path' -- old new + | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode + | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode + | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace + | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' + | ResetRootI (Either ShortBranchHash Path') + -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? + -- Does it make sense to fork from not-the-root of a Github repo? + -- change directory + | SwitchBranchI Path' + | UpI + | PopBranchI + -- > names foo + -- > names foo.bar + -- > names .foo.bar + -- > names .foo.bar#asdflkjsdf + -- > names #sdflkjsdfhsdf + | NamesI (HQ.HashQualified Name) + | AliasTermI HashOrHQSplit' Path.Split' + | AliasTypeI HashOrHQSplit' Path.Split' + | AliasManyI [Path.HQSplit] Path' + -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. + | MoveTermI Path.HQSplit' Path.Split' + | MoveTypeI Path.HQSplit' Path.Split' + | MoveBranchI (Maybe Path.Split') Path.Split' + | MovePatchI Path.Split' Path.Split' + | CopyPatchI Path.Split' Path.Split' + -- delete = unname + | DeleteI Path.HQSplit' + | DeleteTermI Path.HQSplit' + | DeleteTypeI Path.HQSplit' + | DeleteBranchI (Maybe Path.Split') + | DeletePatchI Path.Split' + -- resolving naming conflicts within `branchpath` + -- Add the specified name after deleting all others for a given reference + -- within a given branch. + | ResolveTermNameI Path.HQSplit' + | ResolveTypeNameI Path.HQSplit' + -- edits stuff: + | LoadI (Maybe FilePath) + | 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' + | ReplaceI (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 + | HistoryI (Maybe Int) (Maybe Int) BranchId + -- execute an IO thunk + | ExecuteI String + -- execute an IO [Result] + | IOTestI (HQ.HashQualified Name) + | TestI Bool Bool -- TestI showSuccesses showFailures + -- metadata + -- `link metadata definitions` (adds metadata to all of `definitions`) + | LinkI (HQ.HashQualified Name) [Path.HQSplit'] + -- `unlink metadata definitions` (removes metadata from all of `definitions`) + | UnlinkI (HQ.HashQualified Name) [Path.HQSplit'] + -- links from + | LinksI Path.HQSplit' (Maybe String) + | CreateAuthorI NameSegment {- identifier -} Text {- name -} + | DisplayI OutputLocation (HQ.HashQualified Name) + | DocsI Path.HQSplit' + -- other + | SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query + | FindShallowI Path' + | FindPatchI + | ShowDefinitionI OutputLocation [HQ.HashQualified Name] + | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] + | ShowReflogI + | UpdateBuiltinsI + | MergeBuiltinsI + | MergeIOBuiltinsI + | ListDependenciesI (HQ.HashQualified Name) + | ListDependentsI (HQ.HashQualified Name) + | DebugNumberedArgsI + | DebugTypecheckedUnisonFileI + | DebugDumpNamespacesI + | DebugDumpNamespaceSimpleI + | DebugClearWatchI + | QuitI + | UiI + deriving (Eq, Show) -- <<< RLM: Need to figure this one out + +-- Some commands, like `view`, can dump output to either console or a file. +data OutputLocation + = ConsoleLocation + | LatestFileLocation + | FileLocation FilePath + -- ClipboardLocation + deriving (Eq, Show) + +-- OUTPUT STUFF BELOW +type ListDetailed = Bool +type NumberedArgs = [String] + +data PushPull = Push | Pull deriving (Eq, Ord, Show) + +pushPull :: a -> a -> PushPull -> a +pushPull push pull p = case p of + Push -> push + Pull -> pull + +data NumberedOutput v + = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + -- + | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + +-- | ShowDiff + +-- RLM: SPIKE - Ok a creative but potentially bad idea that would solve many of my woes is to break out Output v into OutputWithNoType Parameter. +data OutputSimple + = Onboarding String + | Success + deriving (Eq, Show) + +data Output v + -- Generic Success response; we might consider deleting this. + = Simple OutputSimple -- RLM: Test here + -- User did `add` or `update` before typechecking a file? + | NoUnisonFile + | InvalidSourceName String + | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' + | CreatedNewBranch Path.Absolute + | BranchAlreadyExists Path' + | PatchAlreadyExists Path.Split' + | NoExactTypeMatches + | TypeAlreadyExists Path.Split' (Set Reference) + | TypeParseError String (Parser.Err v) + | ParseResolutionFailures String [Names.ResolutionFailure v Ann] + | TypeHasFreeVars (Type v Ann) + | TermAlreadyExists Path.Split' (Set Referent) + | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) + | LabeledReferenceNotFound (HQ.HashQualified Name) + | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) + | TermAmbiguous (HQ.HashQualified Name) (Set Referent) + | HashAmbiguous ShortHash (Set Referent) + | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) + | BranchNotFound Path' + | NameNotFound Path.HQSplit' + | PatchNotFound Path.Split' + | TypeNotFound Path.HQSplit' + | TermNotFound Path.HQSplit' + | TypeNotFound' ShortHash + | TermNotFound' ShortHash + | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) + | 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 + -- the path is deleted. + | DeleteBranchConfirmation + [(Path', (Names, [SearchResult' v Ann]))] + -- CantDelete input couldntDelete becauseTheseStillReferenceThem + | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] + | DeleteEverythingConfirmation + | DeletedEverything + | ListNames Int -- hq length to print References + [(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 Name, Reference, Maybe (Type v Ann))] + | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] + | ListOfPatches (Set Name) + -- show the result of add/update + | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) + -- Original source, followed by the errors: + | ParseErrors Text [Parser.Err v] + | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] + | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] + | DisplayConflicts (Relation Name Referent) (Relation Name Reference) + | EvaluationFailure Runtime.Error + | Evaluated SourceFileContents + PPE.PrettyPrintEnv + [(v, Term v ())] + (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) + | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) + | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) + -- "display" definitions, possibly to a FilePath on disk (e.g. editing) + | DisplayDefinitions (Maybe FilePath) + PPE.PrettyPrintEnvDecl + (Map Reference (DisplayObject () (Decl v Ann))) + (Map Reference (DisplayObject (Type v Ann) (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) + | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) + | TestResults TestReportStats + PPE.PrettyPrintEnv ShowSuccesses ShowFailures + [(Reference, Text)] -- oks + [(Reference, Text)] -- fails + | CantUndo UndoFailureReason + | ListEdits Patch PPE.PrettyPrintEnv + + -- new/unrepresented references followed by old/removed + -- todo: eventually replace these sets with [SearchResult' v Ann] + -- and a nicer render. + | BustedBuiltins (Set Reference) (Set Reference) + | GitError Input GitError + | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) + | NoConfiguredGitUrl PushPull Path' + | ConfiguredGitUrlParseError PushPull Path' Text String + | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata + (Map Reference (DisplayObject () (Decl v Ann))) + (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) + | MetadataMissingType 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 + | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) + | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) + | StartOfCurrentPathHistory + | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail + | ShowReflog [ReflogEntry] + | PullAlreadyUpToDate ReadRemoteNamespace Path' + | MergeAlreadyUpToDate Path' Path' + | PreviewMergeAlreadyUpToDate Path' Path' + -- | No conflicts or edits remain for the current patch. + | NoConflictsOrEdits + | NotImplemented + | NoBranchWithHash ShortBranchHash + | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) + | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) + | DumpNumberedArgs NumberedArgs + | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) + | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] + | BadName String + | DefaultMetadataNotification + | BadRootBranch GetRootBranchError + | CouldntLoadBranch Branch.Hash + | NoOp + deriving (Show) + +data ReflogEntry = + ReflogEntry { hash :: ShortBranchHash, reason :: Text } + deriving (Show) + +data HistoryTail = + EndOfLog ShortBranchHash | + MergeTail ShortBranchHash [ShortBranchHash] | + PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex + deriving (Show) + +data TestReportStats + = CachedTests TotalCount CachedCount + | NewlyComputed deriving Show + +type TotalCount = Int -- total number of tests +type CachedCount = Int -- number of tests found in the cache +type ShowSuccesses = Bool -- whether to list results or just summarize +type ShowFailures = Bool -- whether to list results or just summarize + +data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show + +type SourceFileContents = Text + +isFailure :: Ord v => Output v -> Bool +isFailure o = case o of + Simple Success{} -> False + Simple Onboarding{} -> False + BadRootBranch{} -> True + CouldntLoadBranch{} -> True + NoUnisonFile{} -> True + InvalidSourceName{} -> True + SourceLoadFailed{} -> True + NoMainFunction{} -> True + BadMainFunction{} -> True + CreatedNewBranch{} -> False + BranchAlreadyExists{} -> True + PatchAlreadyExists{} -> True + NoExactTypeMatches -> True + BranchEmpty{} -> True + BranchNotEmpty{} -> True + TypeAlreadyExists{} -> True + TypeParseError{} -> True + ParseResolutionFailures{} -> True + TypeHasFreeVars{} -> True + TermAlreadyExists{} -> True + LabeledReferenceAmbiguous{} -> True + LabeledReferenceNotFound{} -> True + DeleteNameAmbiguous{} -> True + TermAmbiguous{} -> True + BranchHashAmbiguous{} -> True + BadName{} -> True + BranchNotFound{} -> True + NameNotFound{} -> True + PatchNotFound{} -> True + TypeNotFound{} -> True + TypeNotFound'{} -> True + TermNotFound{} -> True + TermNotFound'{} -> True + TypeTermMismatch{} -> True + SearchTermsNotFound ts -> not (null ts) + DeleteBranchConfirmation{} -> False + CantDelete{} -> True + DeleteEverythingConfirmation -> False + DeletedEverything -> False + ListNames _ tys tms -> null tms && null tys + ListOfLinks _ ds -> null ds + ListOfDefinitions _ _ ds -> null ds + ListOfPatches s -> Set.null s + SlurpOutput _ _ sr -> not $ SR.isOk sr + ParseErrors{} -> True + TypeErrors{} -> True + CompilerBugs{} -> True + DisplayConflicts{} -> False + EvaluationFailure{} -> True + Evaluated{} -> False + Typechecked{} -> False + DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 + DisplayRendered{} -> False + TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) + TestIncrementalOutputStart{} -> False + TestIncrementalOutputEnd{} -> False + TestResults _ _ _ _ _ fails -> not (null fails) + CantUndo{} -> True + ListEdits{} -> False + GitError{} -> True + BustedBuiltins{} -> True + ConfiguredMetadataParseError{} -> True + NoConfiguredGitUrl{} -> True + ConfiguredGitUrlParseError{} -> True + DisplayLinks{} -> False + MetadataMissingType{} -> True + MetadataAmbiguous{} -> True + PatchNeedsToBeConflictFree{} -> True + PatchInvolvesExternalDependents{} -> True + NothingToPatch{} -> False + WarnIncomingRootBranch{} -> False + History{} -> False + StartOfCurrentPathHistory -> True + NotImplemented -> True + DumpNumberedArgs{} -> False + DumpBitBooster{} -> False + NoBranchWithHash{} -> True + PullAlreadyUpToDate{} -> False + MergeAlreadyUpToDate{} -> False + PreviewMergeAlreadyUpToDate{} -> False + NoConflictsOrEdits{} -> False + ListShallow _ es -> null es + HashAmbiguous{} -> True + ShowReflog{} -> False + LoadPullRequest{} -> False + DefaultMetadataNotification -> False + NoOp -> False + ListDependencies{} -> False + ListDependents{} -> False + TermMissingType{} -> True + DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty + +isNumberedFailure :: NumberedOutput v -> Bool +isNumberedFailure = \case + ShowDiffNamespace{} -> False + ShowDiffAfterDeleteDefinitions{} -> False + ShowDiffAfterDeleteBranch{} -> False + ShowDiffAfterModifyBranch{} -> False + ShowDiffAfterMerge{} -> False + ShowDiffAfterMergePropagate{} -> False + ShowDiffAfterMergePreview{} -> False + ShowDiffAfterUndo{} -> False + ShowDiffAfterPull{} -> False + ShowDiffAfterCreatePR{} -> False + ShowDiffAfterCreateAuthor{} -> False + + diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index 09d4495a57..3641e54ce2 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -1,348 +1,351 @@ {-# LANGUAGE PatternSynonyms #-} module Unison.Codebase.Editor.Output - ( Output(..) - , NumberedOutput(..) - , NumberedArgs - , ListDetailed - , HistoryTail(..) - , TestReportStats(..) - , UndoFailureReason(..) - , PushPull(..) - , ReflogEntry(..) - , pushPull - , isFailure - , isNumberedFailure - ) where + -- ( Output(..) + -- , NumberedOutput(..) + -- , NumberedArgs + -- , ListDetailed + -- , HistoryTail(..) + -- , TestReportStats(..) + -- , UndoFailureReason(..) + -- , PushPull(..) + -- , ReflogEntry(..) + -- , pushPull + -- , isFailure + -- , isNumberedFailure) +where -import Unison.Prelude +-- 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.Path (Path') -import Unison.Codebase.Patch (Patch) -import Unison.Codebase.Type (GitError) -import Unison.Name ( Name ) -import Unison.Names2 ( Names ) -import Unison.Parser.Ann (Ann) -import qualified Unison.Reference as Reference -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) -import Unison.DataDeclaration ( Decl ) -import Unison.Util.Relation (Relation) -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Editor.SlurpResult as SR -import qualified Unison.Codebase.Metadata as Metadata -import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Runtime as Runtime -import qualified Unison.HashQualified as HQ -import qualified Unison.HashQualified' as HQ' -import qualified Unison.Parser as Parser -import qualified Unison.PrettyPrintEnv as PPE -import qualified Unison.PrettyPrintEnvDecl as PPE -import qualified Unison.Typechecker.Context as Context -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Pretty as P -import Unison.Codebase.Editor.DisplayObject (DisplayObject) -import qualified Unison.Codebase.Editor.TodoOutput as TO -import Unison.Server.SearchResult' (SearchResult') -import Unison.Term (Term) -import Unison.Type (Type) -import qualified Unison.Names.ResolutionResult as Names -import qualified Unison.Names3 as Names -import qualified Data.Set as Set -import Unison.NameSegment (NameSegment) -import Unison.ShortHash (ShortHash) -import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import Unison.Codebase.Editor.RemoteRepo -import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) -import Unison.LabeledDependency (LabeledDependency) -import qualified Unison.WatchKind as WK +-- import Unison.Server.Backend (ShallowListEntry(..)) +-- -- import Unison.Codebase.Editor.InputOutput +-- import Unison.Codebase.Editor.Input +-- import Unison.Codebase (GetRootBranchError) +-- import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) +-- import Unison.Codebase.Path (Path') +-- import Unison.Codebase.Patch (Patch) +-- import Unison.Codebase.Type (GitError) +-- import Unison.Name ( Name ) +-- import Unison.Names2 ( Names ) +-- import Unison.Parser.Ann (Ann) +-- import qualified Unison.Reference as Reference +-- import Unison.Reference ( Reference ) +-- import Unison.Referent ( Referent ) +-- import Unison.DataDeclaration ( Decl ) +-- import Unison.Util.Relation (Relation) +-- import qualified Unison.Codebase.Branch as Branch +-- import qualified Unison.Codebase.Editor.SlurpResult as SR +-- import qualified Unison.Codebase.Metadata as Metadata +-- import qualified Unison.Codebase.Path as Path +-- import qualified Unison.Codebase.Runtime as Runtime +-- import qualified Unison.HashQualified as HQ +-- import qualified Unison.HashQualified' as HQ' +-- import qualified Unison.Parser as Parser +-- import qualified Unison.PrettyPrintEnv as PPE +-- import qualified Unison.PrettyPrintEnvDecl as PPE +-- import qualified Unison.Typechecker.Context as Context +-- import qualified Unison.UnisonFile as UF +-- import qualified Unison.Util.Pretty as P +-- import Unison.Codebase.Editor.DisplayObject (DisplayObject) +-- import qualified Unison.Codebase.Editor.TodoOutput as TO +-- import Unison.Server.SearchResult' (SearchResult') +-- import Unison.Term (Term) +-- import Unison.Type (Type) +-- import qualified Unison.Names.ResolutionResult as Names +-- import qualified Unison.Names3 as Names +-- import qualified Data.Set as Set +-- import Unison.NameSegment (NameSegment) +-- import Unison.ShortHash (ShortHash) +-- import Unison.Codebase.ShortBranchHash (ShortBranchHash) +-- import Unison.Codebase.Editor.RemoteRepo +-- import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) +-- import Unison.LabeledDependency (LabeledDependency) +-- import qualified Unison.WatchKind as WK -type ListDetailed = Bool -type SourceName = Text -type NumberedArgs = [String] +-- type ListDetailed = Bool +-- type SourceName = Text +-- type NumberedArgs = [String] -data PushPull = Push | Pull deriving (Eq, Ord, Show) +-- data PushPull = Push | Pull deriving (Eq, Ord, Show) -pushPull :: a -> a -> PushPull -> a -pushPull push pull p = case p of - Push -> push - Pull -> pull +-- pushPull :: a -> a -> PushPull -> a +-- pushPull push pull p = case p of +-- Push -> push +-- Pull -> pull -data NumberedOutput v - = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - -- - | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- data NumberedOutput v +-- = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +-- -- +-- | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiff +-- -- | ShowDiff -data Output v - -- Generic Success response; we might consider deleting this. - = Success - -- User did `add` or `update` before typechecking a file? - | NoUnisonFile - | InvalidSourceName String - | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' - | CreatedNewBranch Path.Absolute - | BranchAlreadyExists Path' - | PatchAlreadyExists Path.Split' - | NoExactTypeMatches - | TypeAlreadyExists Path.Split' (Set Reference) - | TypeParseError String (Parser.Err v) - | ParseResolutionFailures String [Names.ResolutionFailure v Ann] - | TypeHasFreeVars (Type v Ann) - | TermAlreadyExists Path.Split' (Set Referent) - | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) - | LabeledReferenceNotFound (HQ.HashQualified Name) - | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) - | TermAmbiguous (HQ.HashQualified Name) (Set Referent) - | HashAmbiguous ShortHash (Set Referent) - | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) - | BranchNotFound Path' - | NameNotFound Path.HQSplit' - | PatchNotFound Path.Split' - | TypeNotFound Path.HQSplit' - | TermNotFound Path.HQSplit' - | TypeNotFound' ShortHash - | TermNotFound' ShortHash - | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) - | 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 - -- the path is deleted. - | DeleteBranchConfirmation - [(Path', (Names, [SearchResult' v Ann]))] - -- CantDelete input couldntDelete becauseTheseStillReferenceThem - | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] - | DeleteEverythingConfirmation - | DeletedEverything - | ListNames Int -- hq length to print References - [(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 Name, Reference, Maybe (Type v Ann))] - | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] - | ListOfPatches (Set Name) - -- show the result of add/update - | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) - -- Original source, followed by the errors: - | ParseErrors Text [Parser.Err v] - | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] - | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] - | DisplayConflicts (Relation Name Referent) (Relation Name Reference) - | EvaluationFailure Runtime.Error - | Evaluated SourceFileContents - PPE.PrettyPrintEnv - [(v, Term v ())] - (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) - | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) - | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) - -- "display" definitions, possibly to a FilePath on disk (e.g. editing) - | DisplayDefinitions (Maybe FilePath) - PPE.PrettyPrintEnvDecl - (Map Reference (DisplayObject () (Decl v Ann))) - (Map Reference (DisplayObject (Type v Ann) (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) - | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) - | TestResults TestReportStats - PPE.PrettyPrintEnv ShowSuccesses ShowFailures - [(Reference, Text)] -- oks - [(Reference, Text)] -- fails - | CantUndo UndoFailureReason - | ListEdits Patch PPE.PrettyPrintEnv +-- data Output v +-- -- Generic Success response; we might consider deleting this. +-- = Success +-- | Onboarding String -- RLM Test - will eventually do more output +-- -- User did `add` or `update` before typechecking a file? +-- | NoUnisonFile +-- | InvalidSourceName String +-- | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' +-- | CreatedNewBranch Path.Absolute +-- | BranchAlreadyExists Path' +-- | PatchAlreadyExists Path.Split' +-- | NoExactTypeMatches +-- | TypeAlreadyExists Path.Split' (Set Reference) +-- | TypeParseError String (Parser.Err v) +-- | ParseResolutionFailures String [Names.ResolutionFailure v Ann] +-- | TypeHasFreeVars (Type v Ann) +-- | TermAlreadyExists Path.Split' (Set Referent) +-- | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) +-- | LabeledReferenceNotFound (HQ.HashQualified Name) +-- | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) +-- | TermAmbiguous (HQ.HashQualified Name) (Set Referent) +-- | HashAmbiguous ShortHash (Set Referent) +-- | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) +-- | BranchNotFound Path' +-- | NameNotFound Path.HQSplit' +-- | PatchNotFound Path.Split' +-- | TypeNotFound Path.HQSplit' +-- | TermNotFound Path.HQSplit' +-- | TypeNotFound' ShortHash +-- | TermNotFound' ShortHash +-- | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) +-- | 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 +-- -- the path is deleted. +-- | DeleteBranchConfirmation +-- [(Path', (Names, [SearchResult' v Ann]))] +-- -- CantDelete input couldntDelete becauseTheseStillReferenceThem +-- | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] +-- | DeleteEverythingConfirmation +-- | DeletedEverything +-- | ListNames Int -- hq length to print References +-- [(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 Name, Reference, Maybe (Type v Ann))] +-- | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] +-- | ListOfPatches (Set Name) +-- -- show the result of add/update +-- | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) +-- -- Original source, followed by the errors: +-- | ParseErrors Text [Parser.Err v] +-- | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] +-- | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] +-- | DisplayConflicts (Relation Name Referent) (Relation Name Reference) +-- | EvaluationFailure Runtime.Error +-- | Evaluated SourceFileContents +-- PPE.PrettyPrintEnv +-- [(v, Term v ())] +-- (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) +-- | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) +-- | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) +-- -- "display" definitions, possibly to a FilePath on disk (e.g. editing) +-- | DisplayDefinitions (Maybe FilePath) +-- PPE.PrettyPrintEnvDecl +-- (Map Reference (DisplayObject () (Decl v Ann))) +-- (Map Reference (DisplayObject (Type v Ann) (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) +-- | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) +-- | TestResults TestReportStats +-- PPE.PrettyPrintEnv ShowSuccesses ShowFailures +-- [(Reference, Text)] -- oks +-- [(Reference, Text)] -- fails +-- | CantUndo UndoFailureReason +-- | ListEdits Patch PPE.PrettyPrintEnv - -- new/unrepresented references followed by old/removed - -- todo: eventually replace these sets with [SearchResult' v Ann] - -- and a nicer render. - | BustedBuiltins (Set Reference) (Set Reference) - | GitError Input GitError - | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) - | NoConfiguredGitUrl PushPull Path' - | ConfiguredGitUrlParseError PushPull Path' Text String - | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata - (Map Reference (DisplayObject () (Decl v Ann))) - (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) - | MetadataMissingType 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 - | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) - | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) - | StartOfCurrentPathHistory - | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail - | ShowReflog [ReflogEntry] - | PullAlreadyUpToDate ReadRemoteNamespace Path' - | MergeAlreadyUpToDate Path' Path' - | PreviewMergeAlreadyUpToDate Path' Path' - -- | No conflicts or edits remain for the current patch. - | NoConflictsOrEdits - | NotImplemented - | NoBranchWithHash ShortBranchHash - | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) - | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) - | DumpNumberedArgs NumberedArgs - | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) - | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] - | BadName String - | DefaultMetadataNotification - | BadRootBranch GetRootBranchError - | CouldntLoadBranch Branch.Hash - | NoOp - deriving (Show) +-- -- new/unrepresented references followed by old/removed +-- -- todo: eventually replace these sets with [SearchResult' v Ann] +-- -- and a nicer render. +-- | BustedBuiltins (Set Reference) (Set Reference) +-- | GitError GitErr +-- | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) +-- | NoConfiguredGitUrl PushPull Path' +-- | ConfiguredGitUrlParseError PushPull Path' Text String +-- | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata +-- (Map Reference (DisplayObject () (Decl v Ann))) +-- (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) +-- | MetadataMissingType 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 +-- | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) +-- | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) +-- | StartOfCurrentPathHistory +-- | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail +-- | ShowReflog [ReflogEntry] +-- | PullAlreadyUpToDate ReadRemoteNamespace Path' +-- | MergeAlreadyUpToDate Path' Path' +-- | PreviewMergeAlreadyUpToDate Path' Path' +-- -- | No conflicts or edits remain for the current patch. +-- | NoConflictsOrEdits +-- | NotImplemented +-- | NoBranchWithHash ShortBranchHash +-- | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) +-- | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) +-- | DumpNumberedArgs NumberedArgs +-- | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) +-- | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] +-- | BadName String +-- | DefaultMetadataNotification +-- | BadRootBranch GetRootBranchError +-- | CouldntLoadBranch Branch.Hash +-- | NoOp +-- deriving (Show) -data ReflogEntry = - ReflogEntry { hash :: ShortBranchHash, reason :: Text } - deriving (Show) +-- data ReflogEntry = +-- ReflogEntry { hash :: ShortBranchHash, reason :: Text } +-- deriving (Show) -data HistoryTail = - EndOfLog ShortBranchHash | - MergeTail ShortBranchHash [ShortBranchHash] | - PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex - deriving (Show) +-- data HistoryTail = +-- EndOfLog ShortBranchHash | +-- MergeTail ShortBranchHash [ShortBranchHash] | +-- PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex +-- deriving (Show) -data TestReportStats - = CachedTests TotalCount CachedCount - | NewlyComputed deriving Show +-- data TestReportStats +-- = CachedTests TotalCount CachedCount +-- | NewlyComputed deriving Show -type TotalCount = Int -- total number of tests -type CachedCount = Int -- number of tests found in the cache -type ShowSuccesses = Bool -- whether to list results or just summarize -type ShowFailures = Bool -- whether to list results or just summarize +-- type TotalCount = Int -- total number of tests +-- type CachedCount = Int -- number of tests found in the cache +-- type ShowSuccesses = Bool -- whether to list results or just summarize +-- type ShowFailures = Bool -- whether to list results or just summarize -data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show +-- data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show -type SourceFileContents = Text +-- type SourceFileContents = Text -isFailure :: Ord v => Output v -> Bool -isFailure o = case o of - Success{} -> False - BadRootBranch{} -> True - CouldntLoadBranch{} -> True - NoUnisonFile{} -> True - InvalidSourceName{} -> True - SourceLoadFailed{} -> True - NoMainFunction{} -> True - BadMainFunction{} -> True - CreatedNewBranch{} -> False - BranchAlreadyExists{} -> True - PatchAlreadyExists{} -> True - NoExactTypeMatches -> True - BranchEmpty{} -> True - BranchNotEmpty{} -> True - TypeAlreadyExists{} -> True - TypeParseError{} -> True - ParseResolutionFailures{} -> True - TypeHasFreeVars{} -> True - TermAlreadyExists{} -> True - LabeledReferenceAmbiguous{} -> True - LabeledReferenceNotFound{} -> True - DeleteNameAmbiguous{} -> True - TermAmbiguous{} -> True - BranchHashAmbiguous{} -> True - BadName{} -> True - BranchNotFound{} -> True - NameNotFound{} -> True - PatchNotFound{} -> True - TypeNotFound{} -> True - TypeNotFound'{} -> True - TermNotFound{} -> True - TermNotFound'{} -> True - TypeTermMismatch{} -> True - SearchTermsNotFound ts -> not (null ts) - DeleteBranchConfirmation{} -> False - CantDelete{} -> True - DeleteEverythingConfirmation -> False - DeletedEverything -> False - ListNames _ tys tms -> null tms && null tys - ListOfLinks _ ds -> null ds - ListOfDefinitions _ _ ds -> null ds - ListOfPatches s -> Set.null s - SlurpOutput _ _ sr -> not $ SR.isOk sr - ParseErrors{} -> True - TypeErrors{} -> True - CompilerBugs{} -> True - DisplayConflicts{} -> False - EvaluationFailure{} -> True - Evaluated{} -> False - Typechecked{} -> False - DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 - DisplayRendered{} -> False - TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) - TestIncrementalOutputStart{} -> False - TestIncrementalOutputEnd{} -> False - TestResults _ _ _ _ _ fails -> not (null fails) - CantUndo{} -> True - ListEdits{} -> False - GitError{} -> True - BustedBuiltins{} -> True - ConfiguredMetadataParseError{} -> True - NoConfiguredGitUrl{} -> True - ConfiguredGitUrlParseError{} -> True - DisplayLinks{} -> False - MetadataMissingType{} -> True - MetadataAmbiguous{} -> True - PatchNeedsToBeConflictFree{} -> True - PatchInvolvesExternalDependents{} -> True - NothingToPatch{} -> False - WarnIncomingRootBranch{} -> False - History{} -> False - StartOfCurrentPathHistory -> True - NotImplemented -> True - DumpNumberedArgs{} -> False - DumpBitBooster{} -> False - NoBranchWithHash{} -> True - PullAlreadyUpToDate{} -> False - MergeAlreadyUpToDate{} -> False - PreviewMergeAlreadyUpToDate{} -> False - NoConflictsOrEdits{} -> False - ListShallow _ es -> null es - HashAmbiguous{} -> True - ShowReflog{} -> False - LoadPullRequest{} -> False - DefaultMetadataNotification -> False - NoOp -> False - ListDependencies{} -> False - ListDependents{} -> False - TermMissingType{} -> True - DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty +-- isFailure :: Ord v => Output v -> Bool +-- isFailure o = case o of +-- Success{} -> False +-- Onboarding{} -> False +-- BadRootBranch{} -> True +-- CouldntLoadBranch{} -> True +-- NoUnisonFile{} -> True +-- InvalidSourceName{} -> True +-- SourceLoadFailed{} -> True +-- NoMainFunction{} -> True +-- BadMainFunction{} -> True +-- CreatedNewBranch{} -> False +-- BranchAlreadyExists{} -> True +-- PatchAlreadyExists{} -> True +-- NoExactTypeMatches -> True +-- BranchEmpty{} -> True +-- BranchNotEmpty{} -> True +-- TypeAlreadyExists{} -> True +-- TypeParseError{} -> True +-- ParseResolutionFailures{} -> True +-- TypeHasFreeVars{} -> True +-- TermAlreadyExists{} -> True +-- LabeledReferenceAmbiguous{} -> True +-- LabeledReferenceNotFound{} -> True +-- DeleteNameAmbiguous{} -> True +-- TermAmbiguous{} -> True +-- BranchHashAmbiguous{} -> True +-- BadName{} -> True +-- BranchNotFound{} -> True +-- NameNotFound{} -> True +-- PatchNotFound{} -> True +-- TypeNotFound{} -> True +-- TypeNotFound'{} -> True +-- TermNotFound{} -> True +-- TermNotFound'{} -> True +-- TypeTermMismatch{} -> True +-- SearchTermsNotFound ts -> not (null ts) +-- DeleteBranchConfirmation{} -> False +-- CantDelete{} -> True +-- DeleteEverythingConfirmation -> False +-- DeletedEverything -> False +-- ListNames _ tys tms -> null tms && null tys +-- ListOfLinks _ ds -> null ds +-- ListOfDefinitions _ _ ds -> null ds +-- ListOfPatches s -> Set.null s +-- SlurpOutput _ _ sr -> not $ SR.isOk sr +-- ParseErrors{} -> True +-- TypeErrors{} -> True +-- CompilerBugs{} -> True +-- DisplayConflicts{} -> False +-- EvaluationFailure{} -> True +-- Evaluated{} -> False +-- Typechecked{} -> False +-- DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 +-- DisplayRendered{} -> False +-- TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) +-- TestIncrementalOutputStart{} -> False +-- TestIncrementalOutputEnd{} -> False +-- TestResults _ _ _ _ _ fails -> not (null fails) +-- CantUndo{} -> True +-- ListEdits{} -> False +-- GitError{} -> True +-- BustedBuiltins{} -> True +-- ConfiguredMetadataParseError{} -> True +-- NoConfiguredGitUrl{} -> True +-- ConfiguredGitUrlParseError{} -> True +-- DisplayLinks{} -> False +-- MetadataMissingType{} -> True +-- MetadataAmbiguous{} -> True +-- PatchNeedsToBeConflictFree{} -> True +-- PatchInvolvesExternalDependents{} -> True +-- NothingToPatch{} -> False +-- WarnIncomingRootBranch{} -> False +-- History{} -> False +-- StartOfCurrentPathHistory -> True +-- NotImplemented -> True +-- DumpNumberedArgs{} -> False +-- DumpBitBooster{} -> False +-- NoBranchWithHash{} -> True +-- PullAlreadyUpToDate{} -> False +-- MergeAlreadyUpToDate{} -> False +-- PreviewMergeAlreadyUpToDate{} -> False +-- NoConflictsOrEdits{} -> False +-- ListShallow _ es -> null es +-- HashAmbiguous{} -> True +-- ShowReflog{} -> False +-- LoadPullRequest{} -> False +-- DefaultMetadataNotification -> False +-- NoOp -> False +-- ListDependencies{} -> False +-- ListDependents{} -> False +-- TermMissingType{} -> True +-- DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty -isNumberedFailure :: NumberedOutput v -> Bool -isNumberedFailure = \case - ShowDiffNamespace{} -> False - ShowDiffAfterDeleteDefinitions{} -> False - ShowDiffAfterDeleteBranch{} -> False - ShowDiffAfterModifyBranch{} -> False - ShowDiffAfterMerge{} -> False - ShowDiffAfterMergePropagate{} -> False - ShowDiffAfterMergePreview{} -> False - ShowDiffAfterUndo{} -> False - ShowDiffAfterPull{} -> False - ShowDiffAfterCreatePR{} -> False - ShowDiffAfterCreateAuthor{} -> False +-- isNumberedFailure :: NumberedOutput v -> Bool +-- isNumberedFailure = \case +-- ShowDiffNamespace{} -> False +-- ShowDiffAfterDeleteDefinitions{} -> False +-- ShowDiffAfterDeleteBranch{} -> False +-- ShowDiffAfterModifyBranch{} -> False +-- ShowDiffAfterMerge{} -> False +-- ShowDiffAfterMergePropagate{} -> False +-- ShowDiffAfterMergePreview{} -> False +-- ShowDiffAfterUndo{} -> False +-- ShowDiffAfterPull{} -> False +-- ShowDiffAfterCreatePR{} -> False +-- ShowDiffAfterCreateAuthor{} -> False diff --git a/parser-typechecker/src/Unison/CommandLine.hs b/parser-typechecker/src/Unison/CommandLine.hs index 2d02ff37bd..e3773c4ad8 100644 --- a/parser-typechecker/src/Unison/CommandLine.hs +++ b/parser-typechecker/src/Unison/CommandLine.hs @@ -27,7 +27,7 @@ import qualified Unison.Codebase as Codebase 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 Unison.Codebase.Editor.InputOutput (Event(..), Input(..)) import qualified Unison.Server.SearchResult as SR import qualified Unison.Codebase.Watch as Watch import Unison.CommandLine.InputPattern (InputPattern (parse)) diff --git a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs index c1a55d6499..97542ddab0 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs @@ -8,7 +8,7 @@ module Unison.CommandLine.InputPattern where import qualified System.Console.Haskeline as Line import Unison.Codebase (Codebase) import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Editor.Input (Input (..)) +import Unison.Codebase.Editor.InputOutput (Input (..)) import qualified Unison.Util.ColorText as CT import qualified Unison.Util.Pretty as P import Unison.Codebase.Path as Path diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index 61035ce37f..2ade6deedf 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -115,13 +115,13 @@ main -> IO () main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase - Welcome.run codebase welcome eventQueue <- Q.newIO + welcomeEvents <-Welcome.run codebase welcome do -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef initialInputs -- Idea: Extract + initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs -- Idea: Extract numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir @@ -156,9 +156,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba (putPrettyNonempty o) (putPrettyLnUnpaged o)) let - awaitInput = do + awaitInput = do -- await input ends up encompassing initial inputs (for welcome) and the user inputs -- use up buffered input before consulting external events - i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands + i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands welcome.downloadBase initialInputsRef -> initialInputsRef (case i of h:t -> writeIORef initialInputsRef t >> pure h -- Here was where we used to write the IO of commands to the event queue. Will need to mimic in an new function [] -> @@ -168,7 +168,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let e = Left <$> atomically (Q.dequeue eventQueue) writeIORef pageOutput False e - x -> do + x -> do -- x is Input writeIORef pageOutput True pure x) `catch` interruptHandler interruptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 182b9a3e6f..af0e1912e5 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -12,9 +12,9 @@ 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 Unison.Codebase.Editor.InputOutput +import qualified Unison.Codebase.Editor.InputOutput as E +import qualified Unison.Codebase.Editor.InputOutput as Output import qualified Unison.Codebase.Editor.TodoOutput as TO import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD import qualified Unison.Server.SearchResult' as SR' @@ -104,7 +104,7 @@ import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import Unison.Codebase.Editor.DisplayObject (DisplayObject(MissingObject, BuiltinObject, UserObject)) -import qualified Unison.Codebase.Editor.Input as Input +-- import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Hash as Hash import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo @@ -118,6 +118,7 @@ import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError(UnrecognizedSchemaVersion, GitCouldntParseRootBranchHash)) import qualified Unison.Referent' as Referent import qualified Unison.WatchKind as WK +import qualified Unison.Codebase.Editor.InputOutput as Input type Pretty = P.Pretty P.ColorText @@ -256,7 +257,12 @@ 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." + -- Onboarding string -> do + -- pure ( P.bold $ P.string ("HEY THIS IS ONBOARDING TEST responding to step: " ++ string)) + Simple Success -> pure $ P.bold "Done." + Simple (Onboarding string) -> do + pure ( P.bold $ P.string ("HEY THIS IS ONBOARDING TEST responding to step: " ++ string)) BadRootBranch e -> case e of Codebase.NoRootBranch -> pure . P.fatalCallout $ "I couldn't find the codebase root!" diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 22085d1b1b..98f8c8fc3d 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -9,18 +9,25 @@ import qualified Unison.Util.Pretty as P import qualified Unison.PrettyTerminal as PT import System.Random (randomRIO) import Unison.Codebase.Path (Path) -{- + import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode -import Unison.Codebase.Editor.Input (Input (..), Event) +import Unison.Codebase.Editor.InputOutput import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) --} + import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +-- import qualified Unison.Codebase.Editor.Input as Input -- IDEAS? +-- Notes: +-- Download base should be quieter - the printout is annoyingly large. +-- use more primitive IO functions for user input and git download. +-- UX issue / design constraint: if we use existing input / output architecture, how will we constrain the user into only entering their authorship info? +-- we don't want the user to have too much "freedom" when entering their author info. + -- 1) -- * Refactor existing IO command loop out of main function - see notes in CommandLine.main -- * In Welcome.run; use existing interpreter to run commands @@ -31,20 +38,20 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -- * Merge import result into .base -- WELCOME -data Welcome = Welcome +data Welcome = Welcome { onboarding :: Onboarding -- Onboarding States , downloadBase :: DownloadBase , newCodebasePath :: Maybe FilePath - , watchDir :: FilePath - , unisonVersion :: String + , watchDir :: FilePath + , unisonVersion :: String } -- ONBOARDING data CodebaseInitStatus = NewlyCreatedCodebase FilePath -- Can transition to [Base, Author, Finished] - | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. TODO: Show which codebase path was actually opened... + | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. RLM: TODO Show which codebase path was actually opened... -data Onboarding +data Onboarding = Init CodebaseInitStatus -- Can transition to [Base, Author, Finished, PreviouslyOnboarded] | Base BaseSteps -- Can transition to [Author, Finished] | Author -- Can traisition to [Finished] @@ -52,6 +59,7 @@ data Onboarding | Finished | PreviouslyOnboarded + -- ucm start -- create codebase -- .... @@ -71,7 +79,7 @@ data Onboarding -- onboarding -- this is my 100th time and i've got a codebase, and author and base -> PreviouslyOnboarded -data BaseSteps +data BaseSteps = DownloadingBase ReadRemoteNamespace | DownloadBaseFailed ReadRemoteNamespace Text | DownloadBaseSucceeded ReadRemoteNamespace @@ -80,56 +88,69 @@ data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase welcome :: DownloadBase -> Maybe FilePath -> FilePath -> String -> Welcome welcome downloadBase newCodebasePath watchDir unisonVersion = - case newCodebasePath of + case newCodebasePath of Just path -> Welcome (Init (NewlyCreatedCodebase path)) downloadBase newCodebasePath watchDir unisonVersion Nothing -> Welcome (Init PreviouslyCreatedCodebase) downloadBase newCodebasePath watchDir unisonVersion - -run :: Codebase IO v a -> Welcome -> IO () + +-- remove IO +pullBase :: ReadRemoteNamespace -> IO (Either Event Input) +pullBase _ns = + let + seg = NameSegment "base" + rootPath = Path.Path { Path.toSeq = singleton seg } + abs = Path.Absolute {Path.unabsolute = rootPath} + pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete + output = Onboarding " THIS IS A TEST OF PULLING BASE!!" + in + pure $ Right (RespondToInput pullRemote output) + +run :: Codebase IO v a -> Welcome -> IO [Either Event Input] run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do - go onboarding + go onboarding [] where - go :: Onboarding -> IO () - go onboarding = - case onboarding of - Init (NewlyCreatedCodebase path) -> do + go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] + go onboarding acc = + case onboarding of + Init (NewlyCreatedCodebase path) -> do PT.putPrettyLn (header version) PT.putPrettyLn (createdCodebase path) - - determineFirstStep >>= go + determineFirstStep >>= \step -> go step acc Init PreviouslyCreatedCodebase -> do PT.putPrettyLn (header version) - - determineFirstStep >>= go + determineFirstStep >>= \step -> go step acc Base (DownloadingBase ns@(_, _, path)) -> do PT.putPrettyLn $ downloading path res <- pullBase ns case res of Right _ -> - go $ Base $ DownloadBaseSucceeded ns - Left errorMsg -> - go $ Base $ DownloadBaseFailed ns errorMsg - - Base (DownloadBaseSucceeded _) -> do + go baseStep (res : acc) + where + baseStep = Base (DownloadBaseSucceeded ns) + Left _ -> -- event but baseDownload isn't an event so maybe change that type also this is probably a state we can't represent if we use the existing architecture + go baseError acc + where + baseError = Base (DownloadBaseFailed ns "Failed to download base") + Base (DownloadBaseSucceeded _) -> do PT.putPrettyLn $ P.lines [ P.wrap "✅ Success! The base library is the Unison standard library that includes", P.wrap "core types and functions to write Unison code." ] -- getStarted dir >>= PT.putPrettyLn - - go Author + + go Author acc Base (DownloadBaseFailed _ _) -> do PT.putPrettyLn "Download Failed" getStarted dir >>= PT.putPrettyLn - - Author -> do + pure acc + Author -> do PT.putPrettyLn "Enter your author!" - go Finished - - Finished -> + go Finished acc + Finished -> do getStarted dir >>= PT.putPrettyLn - - PreviouslyOnboarded -> + pure acc + PreviouslyOnboarded -> do getStarted dir >>= PT.putPrettyLn + pure acc determineFirstStep :: IO Onboarding determineFirstStep = do @@ -140,22 +161,6 @@ run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, wat _ -> pure $ PreviouslyOnboarded - - --- HELPERS - -pullBase :: ReadRemoteNamespace -> IO (Either Text ()) -pullBase _ns = - {- - let - seg = NameSegment "base" - rootPath = Path.Path { Path.toSeq = singleton seg } - abs = Path.Absolute {Path.unabsolute = rootPath} - in do - -} - pure $ Right () - -- PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete - asciiartUnison :: P.Pretty P.ColorText asciiartUnison = P.red " _____" diff --git a/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs b/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs new file mode 100644 index 0000000000..9b256e00cb --- /dev/null +++ b/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.CommandLine.WelcomeInputQueue where + +import Unison.Prelude + +import Control.Concurrent.STM (atomically) +-- import Control.Exception (finally, catch, AsyncException(UserInterrupt), asyncExceptionFromException) +-- import Control.Monad.State (runStateT) +-- import Data.Configurator.Types (Config) +import Data.IORef +import Prelude hiding (readFile, writeFile) +-- import System.IO.Error (isDoesNotExistError) +import Unison.Codebase.Branch (Branch) +-- import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.Editor.Input (Input (..), Event) +-- import qualified Unison.Server.CodebaseServer as Server +-- import qualified Unison.Codebase.Editor.HandleInput as HandleInput +-- import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand +-- import Unison.Codebase.Editor.Command (LoadSourceResult(..)) +import Unison.Codebase (Codebase) +import Unison.CommandLine +import Unison.PrettyTerminal +import Unison.CommandLine.InputPattern (ArgumentType (suggestions), InputPattern (aliases, patternName)) +import Unison.CommandLine.InputPatterns (validInputs) +-- import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) +import Unison.Parser.Ann (Ann) +import Unison.Symbol (Symbol) +import qualified Control.Concurrent.Async as Async +import qualified Data.Map as Map +import qualified System.Console.Haskeline as Line +import qualified Unison.Codebase.Path as Path +import qualified Unison.CommandLine.InputPattern as IP +import qualified Unison.Util.Pretty as P +import qualified Unison.Util.TQueue as Q +import Text.Regex.TDFA + +-- Expand a numeric argument like `1` or a range like `3-9` +expandNumber :: [String] -> String -> [String] +expandNumber numberedArgs s = + maybe [s] + (map (\i -> fromMaybe (show i) . atMay numberedArgs $ i - 1)) + expandedNumber + where + rangeRegex = "([0-9]+)-([0-9]+)" :: String + (junk,_,moreJunk, ns) = + s =~ rangeRegex :: (String, String, String, [String]) + expandedNumber = + case readMay s of + Just i -> Just [i] + Nothing -> + -- check for a range + case (junk, moreJunk, ns) of + ("", "", [from, to]) -> + (\x y -> [x..y]) <$> readMay from <*> readMay to + _ -> Nothing + +getInput :: IORef (Branch IO) -> IORef Path.Absolute -> IORef [String] -> Codebase IO v a -> IO Input +getInput rootRef pathRef numberedArgsRef codebase = do + root <- readIORef rootRef + path <- readIORef pathRef + numberedArgs <- readIORef numberedArgsRef + getUserInput patternMap codebase root path numberedArgs + where patternMap = Map.fromList $ validInputs >>= (\p -> (patternName p, p) : ((, p) <$> aliases p)) + +getUserInput + :: (MonadIO m, Line.MonadException m) + => Map String InputPattern + -> Codebase m v a + -> Branch m + -> Path.Absolute + -> [String] + -> m Input +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) + 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 + settings = Line.Settings tabComplete (Just ".unisonHistory") True + tabComplete = Line.completeWordWithPrev Nothing " " $ \prev word -> + -- User hasn't finished a command name, complete from command names + if null prev + then pure . exactComplete word $ Map.keys patterns + -- User has finished a command name; use completions for that command + else case words $ reverse prev of + h : t -> fromMaybe (pure []) $ do + p <- Map.lookup h patterns + argType <- IP.argType p (length t) + pure $ suggestions argType word codebase branch currentPath + _ -> pure [] + + +awaitInput :: + [Either Event Input] + -> Q.TQueue Event + -> IORef Bool + -> IORef (Branch IO) + -> IORef Path.Absolute + -> IORef [String] + -> Codebase IO Symbol Ann + -> IO (Either Event Input) +awaitInput initialInputs eventQueue pageOutput rootRef pathRef numberedArgsRef codebase = do -- await input ends up encompassing initial inputs (for welcome) and the user inputs + -- use up buffered input before consulting external events + initialInputsRef <- newIORef initialInputs + i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands + (case i of + h:t -> writeIORef initialInputsRef t >> pure h -- Here was where we used to write the IO of commands to the event queue. Will need to mimic in an new function + [] -> -- this means the initial inputs are done + -- Race the user input and file watch. + Async.race (atomically $ Q.peek eventQueue) (getInput rootRef pathRef numberedArgsRef codebase) >>= \case + Left _ -> do + let e = Left <$> atomically (Q.dequeue eventQueue) + writeIORef pageOutput False + e + x -> do + writeIORef pageOutput True + pure x) --`catch` interruptHandler + --interuptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput initialInputs eventQueue pageOutput rootRef pathRef numberedArgsRef codebase + --interruptHandler e = error (show e) + From 38ebccc2015202822021590134ae5abbcd3f96b6 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 24 Sep 2021 17:18:26 -0500 Subject: [PATCH 125/148] Numbered list backend doc rendering fix --- parser-typechecker/src/Unison/Runtime/IOSource.hs | 1 + parser-typechecker/src/Unison/Server/Doc.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index 54ff966c9c..9a07526fb7 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -153,6 +153,7 @@ pattern Doc2Table ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2TableId - pattern Doc2Folded isFolded d d2 <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2FoldedId -> True)) [Term.Boolean' isFolded, d, d2] pattern Doc2Paragraph ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ParagraphId -> True)) (Term.List' (toList -> ds)) pattern Doc2BulletedList ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BulletedListId -> True)) (Term.List' (toList -> ds)) +pattern Doc2NumberedList n ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NumberedListId -> True)) [Term.Nat' n, Term.List' (toList -> ds)] pattern Doc2Section title ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2SectionId -> True)) [title, Term.List' (toList -> ds)] pattern Doc2NamedLink name dest <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NamedLinkId -> True)) [name, dest] pattern Doc2Image alt link caption <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2ImageId -> True)) [alt, link, caption] diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index d00b868066..df7e40e807 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -138,6 +138,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case DD.Doc2Folded isFolded d d2 -> Folded isFolded <$> go d <*> go d2 DD.Doc2Paragraph ds -> Paragraph <$> traverse go ds DD.Doc2BulletedList ds -> BulletedList <$> traverse go ds + DD.Doc2NumberedList n ds -> NumberedList n <$> traverse go ds DD.Doc2Section title ds -> Section <$> go title <*> traverse go ds DD.Doc2NamedLink d1 d2 -> NamedLink <$> go d1 <*> go d2 DD.Doc2Image d1 d2 Decls.OptionalNone' -> Image <$> go d1 <*> go d2 <*> pure Nothing From 1e5a509931e69ca2c9515724a5acc1ad2903b930 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sat, 25 Sep 2021 11:29:57 -0600 Subject: [PATCH 126/148] Renamed to systemTimeMicroseconds and updated transcripts --- parser-typechecker/src/Unison/Builtin.hs | 2 +- .../src/Unison/Runtime/Builtin.hs | 25 +- unison-src/transcripts/alias-many.output.md | 345 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 8 files changed, 204 insertions(+), 216 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 47e14edb8b..35a356a0a4 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -561,7 +561,7 @@ ioBuiltins = , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) , ("IO.systemTime.impl.v3", unit --> iof nat) - , ("IO.systemTime2.impl.v1", unit --> iof int) + , ("IO.systemTimeMicroseconds.v1", unit --> iof int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 4dcd9920cd..ff7047c3f6 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1006,19 +1006,6 @@ outIoFailNat stack1 stack2 stack3 fail nat result = $ TCon eitherReference 1 [nat]) ] -outIoFailInt :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailInt stack1 stack2 stack3 fail int result = - TMatch result . MatchSum $ mapFromList - [ (0, ([BX, BX],) - . TAbss [stack1, stack2] - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) - , (1, ([UN],) - . TAbs stack3 - . TLetD int BX (TCon Ty.intRef 0 [stack3]) - $ TCon eitherReference 1 [int]) - ] - outIoFailBox :: forall v. Var v => v -> v -> v -> v -> ANormal v outIoFailBox stack1 stack2 fail result = TMatch result . MatchSum $ mapFromList @@ -1103,11 +1090,11 @@ unitToEFNat = inUnit unit result $ outIoFailNat stack1 stack2 stack3 fail nat result where (unit, stack1, stack2, stack3, fail, nat, result) = fresh7 --- () -> Either Failure Int -unitToEFInt :: ForeignOp -unitToEFInt = inUnit unit result - $ outIoFailInt stack1 stack2 stack3 fail int result - where (unit, stack1, stack2, stack3, fail, int, result) = fresh7 +-- () -> Int +unitToInt :: ForeignOp +unitToInt = inUnit unit result + $ TCon Ty.intRef 0 [result] + where (unit, result) = fresh2 -- () -> Either Failure a unitToEFBox :: ForeignOp @@ -1585,7 +1572,7 @@ declareForeigns = do declareForeign "IO.systemTime.impl.v3" unitToEFNat $ mkForeignIOF $ \() -> getPOSIXTime - declareForeign "IO.systemTime2.impl.v1" unitToEFInt + declareForeign "IO.systemTimeMicroseconds.v1" unitToInt $ mkForeignIOF $ \() -> fmap (1e6 *) getPOSIXTime declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index dead8bf4ec..1f63cdf54e 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -263,203 +263,204 @@ Let's try it! ->{IO} Either Failure () 199. io2.IO.stdHandle : StdHandle -> Handle 200. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 201. unique type io2.IOError - 202. io2.IOError.AlreadyExists : IOError - 203. io2.IOError.EOF : IOError - 204. io2.IOError.IllegalOperation : IOError - 205. io2.IOError.NoSuchThing : IOError - 206. io2.IOError.PermissionDenied : IOError - 207. io2.IOError.ResourceBusy : IOError - 208. io2.IOError.ResourceExhausted : IOError - 209. io2.IOError.UserError : IOError - 210. unique type io2.IOFailure - 211. builtin type io2.MVar - 212. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 213. io2.MVar.new : a ->{IO} MVar a - 214. io2.MVar.newEmpty : '{IO} MVar a - 215. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 216. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 217. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 218. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 219. io2.MVar.tryPut.impl : MVar a + 201. io2.IO.systemTimeMicroseconds : '{IO} Either Failure Int + 202. unique type io2.IOError + 203. io2.IOError.AlreadyExists : IOError + 204. io2.IOError.EOF : IOError + 205. io2.IOError.IllegalOperation : IOError + 206. io2.IOError.NoSuchThing : IOError + 207. io2.IOError.PermissionDenied : IOError + 208. io2.IOError.ResourceBusy : IOError + 209. io2.IOError.ResourceExhausted : IOError + 210. io2.IOError.UserError : IOError + 211. unique type io2.IOFailure + 212. builtin type io2.MVar + 213. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 214. io2.MVar.new : a ->{IO} MVar a + 215. io2.MVar.newEmpty : '{IO} MVar a + 216. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 217. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 218. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 219. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 220. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 220. io2.MVar.tryRead.impl : MVar a + 221. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 221. io2.MVar.tryTake : MVar a ->{IO} Optional a - 222. unique type io2.SeekMode - 223. io2.SeekMode.AbsoluteSeek : SeekMode - 224. io2.SeekMode.RelativeSeek : SeekMode - 225. io2.SeekMode.SeekFromEnd : SeekMode - 226. builtin type io2.Socket - 227. unique type io2.StdHandle - 228. io2.StdHandle.StdErr : StdHandle - 229. io2.StdHandle.StdIn : StdHandle - 230. io2.StdHandle.StdOut : StdHandle - 231. builtin type io2.STM - 232. io2.STM.atomically : '{STM} a ->{IO} a - 233. io2.STM.retry : '{STM} a - 234. builtin type io2.ThreadId - 235. builtin type io2.Tls - 236. builtin type io2.Tls.Cipher - 237. builtin type io2.Tls.ClientConfig - 238. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 222. io2.MVar.tryTake : MVar a ->{IO} Optional a + 223. unique type io2.SeekMode + 224. io2.SeekMode.AbsoluteSeek : SeekMode + 225. io2.SeekMode.RelativeSeek : SeekMode + 226. io2.SeekMode.SeekFromEnd : SeekMode + 227. builtin type io2.Socket + 228. unique type io2.StdHandle + 229. io2.StdHandle.StdErr : StdHandle + 230. io2.StdHandle.StdIn : StdHandle + 231. io2.StdHandle.StdOut : StdHandle + 232. builtin type io2.STM + 233. io2.STM.atomically : '{STM} a ->{IO} a + 234. io2.STM.retry : '{STM} a + 235. builtin type io2.ThreadId + 236. builtin type io2.Tls + 237. builtin type io2.Tls.Cipher + 238. builtin type io2.Tls.ClientConfig + 239. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 239. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 240. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 240. io2.Tls.ClientConfig.default : Text + 241. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 241. io2.Tls.ClientConfig.versions.set : [Version] + 242. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 242. io2.Tls.decodeCert.impl : Bytes + 243. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 243. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 244. io2.Tls.encodeCert : SignedCert -> Bytes - 245. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 246. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 247. io2.Tls.newClient.impl : ClientConfig + 244. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 245. io2.Tls.encodeCert : SignedCert -> Bytes + 246. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 247. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 248. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 248. io2.Tls.newServer.impl : ServerConfig + 249. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 249. builtin type io2.Tls.PrivateKey - 250. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 251. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 252. builtin type io2.Tls.ServerConfig - 253. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 250. builtin type io2.Tls.PrivateKey + 251. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 252. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 253. builtin type io2.Tls.ServerConfig + 254. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 254. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 255. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 255. io2.Tls.ServerConfig.default : [SignedCert] + 256. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 256. io2.Tls.ServerConfig.versions.set : [Version] + 257. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 257. builtin type io2.Tls.SignedCert - 258. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 259. builtin type io2.Tls.Version - 260. unique type io2.TlsFailure - 261. builtin type io2.TVar - 262. io2.TVar.new : a ->{STM} TVar a - 263. io2.TVar.newIO : a ->{IO} TVar a - 264. io2.TVar.read : TVar a ->{STM} a - 265. io2.TVar.readIO : TVar a ->{IO} a - 266. io2.TVar.swap : TVar a -> a ->{STM} a - 267. io2.TVar.write : TVar a -> a ->{STM} () - 268. unique type IsPropagated - 269. IsPropagated.IsPropagated : IsPropagated - 270. unique type IsTest - 271. IsTest.IsTest : IsTest - 272. unique type Link - 273. builtin type Link.Term - 274. Link.Term : Term -> Link - 275. Link.Term.toText : Term -> Text - 276. builtin type Link.Type - 277. Link.Type : Type -> Link - 278. builtin type List - 279. List.++ : [a] -> [a] -> [a] - 280. List.+: : a -> [a] -> [a] - 281. List.:+ : [a] -> a -> [a] - 282. List.at : Nat -> [a] -> Optional a - 283. List.cons : a -> [a] -> [a] - 284. List.drop : Nat -> [a] -> [a] - 285. List.empty : [a] - 286. List.size : [a] -> Nat - 287. List.snoc : [a] -> a -> [a] - 288. List.take : Nat -> [a] -> [a] - 289. metadata.isPropagated : IsPropagated - 290. metadata.isTest : IsTest - 291. builtin type Nat - 292. Nat.* : Nat -> Nat -> Nat - 293. Nat.+ : Nat -> Nat -> Nat - 294. Nat./ : Nat -> Nat -> Nat - 295. Nat.and : Nat -> Nat -> Nat - 296. Nat.complement : Nat -> Nat - 297. Nat.drop : Nat -> Nat -> Nat - 298. Nat.eq : Nat -> Nat -> Boolean - 299. Nat.fromText : Text -> Optional Nat - 300. Nat.gt : Nat -> Nat -> Boolean - 301. Nat.gteq : Nat -> Nat -> Boolean - 302. Nat.increment : Nat -> Nat - 303. Nat.isEven : Nat -> Boolean - 304. Nat.isOdd : Nat -> Boolean - 305. Nat.leadingZeros : Nat -> Nat - 306. Nat.lt : Nat -> Nat -> Boolean - 307. Nat.lteq : Nat -> Nat -> Boolean - 308. Nat.mod : Nat -> Nat -> Nat - 309. Nat.or : Nat -> Nat -> Nat - 310. Nat.popCount : Nat -> Nat - 311. Nat.pow : Nat -> Nat -> Nat - 312. Nat.shiftLeft : Nat -> Nat -> Nat - 313. Nat.shiftRight : Nat -> Nat -> Nat - 314. Nat.sub : Nat -> Nat -> Int - 315. Nat.toFloat : Nat -> Float - 316. Nat.toInt : Nat -> Int - 317. Nat.toText : Nat -> Text - 318. Nat.trailingZeros : Nat -> Nat - 319. Nat.xor : Nat -> Nat -> Nat - 320. structural type Optional a - 321. Optional.None : Optional a - 322. Optional.Some : a -> Optional a - 323. builtin type Ref - 324. Ref.read : Ref g a ->{g} a - 325. Ref.write : Ref g a -> a ->{g} () - 326. builtin type Request - 327. builtin type Scope - 328. Scope.ref : a ->{Scope s} Ref {Scope s} a - 329. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 330. structural type SeqView a b - 331. SeqView.VElem : a -> b -> SeqView a b - 332. SeqView.VEmpty : SeqView a b - 333. unique type Test.Result - 334. Test.Result.Fail : Text -> Result - 335. Test.Result.Ok : Text -> Result - 336. builtin type Text - 337. Text.!= : Text -> Text -> Boolean - 338. Text.++ : Text -> Text -> Text - 339. Text.drop : Nat -> Text -> Text - 340. Text.empty : Text - 341. Text.eq : Text -> Text -> Boolean - 342. Text.fromCharList : [Char] -> Text - 343. Text.fromUtf8.impl : Bytes -> Either Failure Text - 344. Text.gt : Text -> Text -> Boolean - 345. Text.gteq : Text -> Text -> Boolean - 346. Text.lt : Text -> Text -> Boolean - 347. Text.lteq : Text -> Text -> Boolean - 348. Text.repeat : Nat -> Text -> Text - 349. Text.size : Text -> Nat - 350. Text.take : Nat -> Text -> Text - 351. Text.toCharList : Text -> [Char] - 352. Text.toUtf8 : Text -> Bytes - 353. Text.uncons : Text -> Optional (Char, Text) - 354. Text.unsnoc : Text -> Optional (Text, Char) - 355. todo : a -> b - 356. structural type Tuple a b - 357. Tuple.Cons : a -> b -> Tuple a b - 358. structural type Unit - 359. Unit.Unit : () - 360. Universal.< : a -> a -> Boolean - 361. Universal.<= : a -> a -> Boolean - 362. Universal.== : a -> a -> Boolean - 363. Universal.> : a -> a -> Boolean - 364. Universal.>= : a -> a -> Boolean - 365. Universal.compare : a -> a -> Int - 366. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 367. builtin type Value - 368. Value.dependencies : Value -> [Term] - 369. Value.deserialize : Bytes -> Either Text Value - 370. Value.load : Value ->{IO} Either [Term] a - 371. Value.serialize : Value -> Bytes - 372. Value.value : a -> Value + 258. builtin type io2.Tls.SignedCert + 259. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 260. builtin type io2.Tls.Version + 261. unique type io2.TlsFailure + 262. builtin type io2.TVar + 263. io2.TVar.new : a ->{STM} TVar a + 264. io2.TVar.newIO : a ->{IO} TVar a + 265. io2.TVar.read : TVar a ->{STM} a + 266. io2.TVar.readIO : TVar a ->{IO} a + 267. io2.TVar.swap : TVar a -> a ->{STM} a + 268. io2.TVar.write : TVar a -> a ->{STM} () + 269. unique type IsPropagated + 270. IsPropagated.IsPropagated : IsPropagated + 271. unique type IsTest + 272. IsTest.IsTest : IsTest + 273. unique type Link + 274. builtin type Link.Term + 275. Link.Term : Term -> Link + 276. Link.Term.toText : Term -> Text + 277. builtin type Link.Type + 278. Link.Type : Type -> Link + 279. builtin type List + 280. List.++ : [a] -> [a] -> [a] + 281. List.+: : a -> [a] -> [a] + 282. List.:+ : [a] -> a -> [a] + 283. List.at : Nat -> [a] -> Optional a + 284. List.cons : a -> [a] -> [a] + 285. List.drop : Nat -> [a] -> [a] + 286. List.empty : [a] + 287. List.size : [a] -> Nat + 288. List.snoc : [a] -> a -> [a] + 289. List.take : Nat -> [a] -> [a] + 290. metadata.isPropagated : IsPropagated + 291. metadata.isTest : IsTest + 292. builtin type Nat + 293. Nat.* : Nat -> Nat -> Nat + 294. Nat.+ : Nat -> Nat -> Nat + 295. Nat./ : Nat -> Nat -> Nat + 296. Nat.and : Nat -> Nat -> Nat + 297. Nat.complement : Nat -> Nat + 298. Nat.drop : Nat -> Nat -> Nat + 299. Nat.eq : Nat -> Nat -> Boolean + 300. Nat.fromText : Text -> Optional Nat + 301. Nat.gt : Nat -> Nat -> Boolean + 302. Nat.gteq : Nat -> Nat -> Boolean + 303. Nat.increment : Nat -> Nat + 304. Nat.isEven : Nat -> Boolean + 305. Nat.isOdd : Nat -> Boolean + 306. Nat.leadingZeros : Nat -> Nat + 307. Nat.lt : Nat -> Nat -> Boolean + 308. Nat.lteq : Nat -> Nat -> Boolean + 309. Nat.mod : Nat -> Nat -> Nat + 310. Nat.or : Nat -> Nat -> Nat + 311. Nat.popCount : Nat -> Nat + 312. Nat.pow : Nat -> Nat -> Nat + 313. Nat.shiftLeft : Nat -> Nat -> Nat + 314. Nat.shiftRight : Nat -> Nat -> Nat + 315. Nat.sub : Nat -> Nat -> Int + 316. Nat.toFloat : Nat -> Float + 317. Nat.toInt : Nat -> Int + 318. Nat.toText : Nat -> Text + 319. Nat.trailingZeros : Nat -> Nat + 320. Nat.xor : Nat -> Nat -> Nat + 321. structural type Optional a + 322. Optional.None : Optional a + 323. Optional.Some : a -> Optional a + 324. builtin type Ref + 325. Ref.read : Ref g a ->{g} a + 326. Ref.write : Ref g a -> a ->{g} () + 327. builtin type Request + 328. builtin type Scope + 329. Scope.ref : a ->{Scope s} Ref {Scope s} a + 330. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 331. structural type SeqView a b + 332. SeqView.VElem : a -> b -> SeqView a b + 333. SeqView.VEmpty : SeqView a b + 334. unique type Test.Result + 335. Test.Result.Fail : Text -> Result + 336. Test.Result.Ok : Text -> Result + 337. builtin type Text + 338. Text.!= : Text -> Text -> Boolean + 339. Text.++ : Text -> Text -> Text + 340. Text.drop : Nat -> Text -> Text + 341. Text.empty : Text + 342. Text.eq : Text -> Text -> Boolean + 343. Text.fromCharList : [Char] -> Text + 344. Text.fromUtf8.impl : Bytes -> Either Failure Text + 345. Text.gt : Text -> Text -> Boolean + 346. Text.gteq : Text -> Text -> Boolean + 347. Text.lt : Text -> Text -> Boolean + 348. Text.lteq : Text -> Text -> Boolean + 349. Text.repeat : Nat -> Text -> Text + 350. Text.size : Text -> Nat + 351. Text.take : Nat -> Text -> Text + 352. Text.toCharList : Text -> [Char] + 353. Text.toUtf8 : Text -> Bytes + 354. Text.uncons : Text -> Optional (Char, Text) + 355. Text.unsnoc : Text -> Optional (Text, Char) + 356. todo : a -> b + 357. structural type Tuple a b + 358. Tuple.Cons : a -> b -> Tuple a b + 359. structural type Unit + 360. Unit.Unit : () + 361. Universal.< : a -> a -> Boolean + 362. Universal.<= : a -> a -> Boolean + 363. Universal.== : a -> a -> Boolean + 364. Universal.> : a -> a -> Boolean + 365. Universal.>= : a -> a -> Boolean + 366. Universal.compare : a -> a -> Int + 367. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 368. builtin type Value + 369. Value.dependencies : Value -> [Term] + 370. Value.deserialize : Bytes -> Either Text Value + 371. Value.load : Value ->{IO} Either [Term] a + 372. Value.serialize : Value -> Bytes + 373. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 1ae0f27fe7..514ec95bac 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -61,7 +61,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 50. Value/ (5 definitions) 51. bug (a -> b) 52. crypto/ (12 definitions) - 53. io2/ (122 definitions) + 53. io2/ (123 definitions) 54. metadata/ (2 definitions) 55. todo (a -> b) 56. unsafe/ (1 definition) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 401d46fd05..8ee89ca1cc 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (372 definitions) + 1. builtin/ (373 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (540 definitions) + 1. builtin/ (541 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index b183f4c8f3..d0e1e3b5ef 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #8bi2fepmci + ⊙ #og6imo9b5c - Deletes: feature1.y - ⊙ #0toe0ni06d + ⊙ #ejjdq2ngge + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #8hp71hs6bk + ⊙ #h52in37m2i + Adds / updates: feature1.y - ⊙ #lujhuhd7it + ⊙ #j82gbg1uvj > Moves: Original name New name x master.x - ⊙ #hl2puv6t7v + ⊙ #avc2r4cma9 + Adds / updates: x - □ #rmafm3f1ih (start of history) + □ #4hqp1f8m4t (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index d79279afb8..06ff0de76d 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #12c7nag7oi .old` to make an old namespace + `fork #u52c5mi247 .old` to make an old namespace accessible again, - `reset-root #12c7nag7oi` to reset the root namespace and + `reset-root #u52c5mi247` to reset the root namespace and its history to that of the specified namespace. - 1. #sjer10g2l4 : add - 2. #12c7nag7oi : add - 3. #rmafm3f1ih : builtins.merge + 1. #67d4sv0vfo : add + 2. #u52c5mi247 : add + 3. #4hqp1f8m4t : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index d4af31bcc5..f4eb61a788 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #7ogvf7kc1m (start of history) + □ #1j4m54701m (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #b4nitt6goc + ⊙ #c1nv5mm0nq > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #s92i00andp + ⊙ #a01ahtlahp > Moves: Original name New name Nat.+ Nat.frobnicate - □ #7ogvf7kc1m (start of history) + □ #1j4m54701m (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #b4nitt6goc + ⊙ #c1nv5mm0nq > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #s92i00andp + ⊙ #a01ahtlahp > Moves: Original name New name Nat.+ Nat.frobnicate - □ #7ogvf7kc1m (start of history) + □ #1j4m54701m (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #7ogvf7kc1m (start of history) + □ #1j4m54701m (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #ct8sk813ij + ⊙ #bof572e8h8 - Deletes: Nat.* Nat.+ - □ #7ogvf7kc1m (start of history) + □ #1j4m54701m (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From fc78cc1899ded62b874bff3a9663aaf32711fe82 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sat, 25 Sep 2021 14:01:21 -0600 Subject: [PATCH 127/148] Fix type of ##IO.systemTimeMicroseconds --- parser-typechecker/src/Unison/Builtin.hs | 2 +- parser-typechecker/src/Unison/Runtime/Builtin.hs | 2 +- unison-src/transcripts/alias-many.output.md | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 35a356a0a4..0f9c5fd3b2 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -561,7 +561,7 @@ ioBuiltins = , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) , ("IO.systemTime.impl.v3", unit --> iof nat) - , ("IO.systemTimeMicroseconds.v1", unit --> iof int) + , ("IO.systemTimeMicroseconds.v1", unit --> io int) , ("IO.getTempDirectory.impl.v3", unit --> iof text) , ("IO.createTempDirectory.impl.v3", text --> iof text) , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index ff7047c3f6..b33a71881c 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1573,7 +1573,7 @@ declareForeigns = do $ mkForeignIOF $ \() -> getPOSIXTime declareForeign "IO.systemTimeMicroseconds.v1" unitToInt - $ mkForeignIOF $ \() -> fmap (1e6 *) getPOSIXTime + $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox $ mkForeignIOF $ \() -> getTemporaryDirectory diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 1f63cdf54e..337271f7a3 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -263,7 +263,7 @@ Let's try it! ->{IO} Either Failure () 199. io2.IO.stdHandle : StdHandle -> Handle 200. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 201. io2.IO.systemTimeMicroseconds : '{IO} Either Failure Int + 201. io2.IO.systemTimeMicroseconds : '{IO} Int 202. unique type io2.IOError 203. io2.IOError.AlreadyExists : IOError 204. io2.IOError.EOF : IOError From feecaea0f8d4f23b64d2bbb650954f40a3c60902 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 25 Sep 2021 22:50:06 -0400 Subject: [PATCH 128/148] add constants for optional/either/seqView ctor ids --- .../src/Unison/Builtin/Decls.hs | 3 + .../src/Unison/Runtime/Builtin.hs | 112 ++++++++++-------- 2 files changed, 64 insertions(+), 51 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index b24ebf9fad..292b830098 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -86,6 +86,7 @@ constructorId ref name = do noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId +seqViewEmpty, seqViewElem :: ConstructorId Just noneId = constructorId optionalRef "Optional.None" Just someId = constructorId optionalRef "Optional.Some" Just isPropagatedConstructorId = constructorId isPropagatedRef "IsPropagated.IsPropagated" @@ -102,6 +103,8 @@ Just linkTermId = constructorId linkRef "Link.Term" Just linkTypeId = constructorId linkRef "Link.Type" Just eitherRightId = constructorId eitherRef "Either.Right" Just eitherLeftId = constructorId eitherRef "Either.Left" +Just seqViewEmpty = constructorId seqViewRef "SeqView.VEmpty" +Just seqViewElem = constructorId seqViewRef "SeqView.VElem" Just bufferModeNoBufferingId = constructorId bufferModeRef "io2.BufferMode.NoBuffering" Just bufferModeLineBufferingId = constructorId bufferModeRef "io2.BufferMode.LineBuffering" diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index b33a71881c..d464dc9c71 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -32,7 +32,6 @@ import Unison.Runtime.Foreign ( Foreign(Wrap), HashAlgorithm(..), pattern Failure) import qualified Unison.Runtime.Foreign as F import Unison.Runtime.Foreign.Function -import Unison.Runtime.IOSource (eitherReference) import qualified Unison.Type as Ty import qualified Unison.Builtin as Ty (builtinTypes) @@ -58,7 +57,7 @@ import Data.PEM (pemContent, pemParseLBS, PEM) import Data.Set (insert) import qualified Data.Map as Map -import Unison.Prelude +import Unison.Prelude hiding (some) import qualified Unison.Util.Bytes as Bytes import Network.Socket as SYS ( accept @@ -182,6 +181,17 @@ fls, tru :: Var v => ANormal v fls = TCon Ty.booleanRef 0 [] tru = TCon Ty.booleanRef 1 [] +none :: Var v => ANormal v +none = TCon Ty.optionalRef (toEnum Ty.noneId) [] +some, left, right :: Var v => v -> ANormal v +some a = TCon Ty.optionalRef (toEnum Ty.someId) [a] +left x = TCon Ty.eitherRef (toEnum Ty.eitherLeftId) [x] +right x = TCon Ty.eitherRef (toEnum Ty.eitherRightId) [x] +seqViewEmpty :: Var v => ANormal v +seqViewEmpty = TCon Ty.seqViewRef (toEnum Ty.seqViewEmpty) [] +seqViewElem :: Var v => v -> v -> ANormal v +seqViewElem l r = TCon Ty.seqViewRef (toEnum Ty.seqViewElem) [l,r] + boolift :: Var v => v -> ANormal v boolift v = TMatch v $ MatchIntegral (mapFromList [(0,fls), (1,tru)]) Nothing @@ -440,24 +450,24 @@ sizet = unop0 1 $ \[x,r] unconst = unop0 7 $ \[x,t,c0,c,y,p,u,yp] -> TLetD t UN (TPrm UCNS [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN,BX], TAbss [c0,y] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD yp BX (TCon Ty.pairRef 0 [y,u]) . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD p BX (TCon Ty.pairRef 0 [c,yp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] unsnoct = unop0 7 $ \[x,t,c0,c,y,p,u,cp] -> TLetD t UN (TPrm USNC [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([BX,UN], TAbss [y,c0] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD cp BX (TCon Ty.pairRef 0 [c,u]) . TLetD p BX (TCon Ty.pairRef 0 [y,cp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] appends, conss, snocs :: Var v => SuperNormal v @@ -484,8 +494,8 @@ ats = binop0 3 $ \[x0,y,x,t,r] -> unbox x0 Ty.natRef x . TLetD t UN (TPrm IDXS [x,y]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) + [ (0, ([], none)) + , (1, ([BX], TAbs r $ some r)) ] emptys = Lambda [] $ TPrm BLDS [] @@ -493,14 +503,14 @@ viewls, viewrs :: Var v => SuperNormal v viewls = unop0 3 $ \[s,u,h,t] -> TLetD u UN (TPrm VWLS [s]) . TMatch u . MatchSum $ mapFromList - [ (0, ([], TCon Ty.seqViewRef 0 [])) - , (1, ([BX,BX], TAbss [h,t] $ TCon Ty.seqViewRef 1 [h,t])) + [ (0, ([], seqViewEmpty)) + , (1, ([BX,BX], TAbss [h,t] $ seqViewElem h t)) ] viewrs = unop0 3 $ \[s,u,i,l] -> TLetD u UN (TPrm VWRS [s]) . TMatch u . MatchSum $ mapFromList - [ (0, ([], TCon Ty.seqViewRef 0 [])) - , (1, ([BX,BX], TAbss [i,l] $ TCon Ty.seqViewRef 1 [i,l])) + [ (0, ([], seqViewEmpty)) + , (1, ([BX,BX], TAbss [i,l] $ seqViewElem i l)) ] eqt, neqt, leqt, geqt, lesst, great :: Var v => SuperNormal v @@ -551,10 +561,10 @@ atb = binop0 4 $ \[n0,b,n,t,r0,r] -> unbox n0 Ty.natRef n . TLetD t UN (TPrm IDXB [n,b]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs r0 . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ TCon Ty.optionalRef 1 [r])) + $ some r)) ] sizeb = unop0 1 $ \[b,n] @@ -578,26 +588,26 @@ t2i, t2n, t2f :: Var v => SuperNormal v t2i = unop0 3 $ \[x,t,n0,n] -> TLetD t UN (TPrm TTOI [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs n0 . TLetD n BX (TCon Ty.intRef 0 [n0]) - $ TCon Ty.optionalRef 1 [n])) + $ some n)) ] t2n = unop0 3 $ \[x,t,n0,n] -> TLetD t UN (TPrm TTON [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs n0 . TLetD n BX (TCon Ty.natRef 0 [n0]) - $ TCon Ty.optionalRef 1 [n])) + $ some n)) ] t2f = unop0 3 $ \[x,t,f0,f] -> TLetD t UN (TPrm TTOF [x]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN], TAbs f0 . TLetD f BX (TCon Ty.floatRef 0 [f0]) - $ TCon Ty.optionalRef 1 [f])) + $ some f)) ] equ :: Var v => SuperNormal v @@ -734,8 +744,8 @@ code'lookup = unop0 2 $ \[link,t,r] -> TLetD t UN (TPrm LKUP [link]) . TMatch t . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs r $ TCon Ty.optionalRef 1 [r])) + [ (0, ([], none)) + , (1, ([BX], TAbs r $ some r)) ] code'validate :: Var v => SuperNormal v @@ -747,9 +757,9 @@ code'validate [ (1, ([BX, BX, BX],) . TAbss [ref, msg, extra] . TLetD fail BX (TCon Ty.failureRef 0 [ref, msg, extra]) - $ TCon Ty.optionalRef 1 [fail]) + $ some fail) , (0, ([],) - $ TCon Ty.optionalRef 0 []) + $ none) ] term'link'to'text :: Var v => SuperNormal v @@ -761,8 +771,8 @@ value'load = unop0 2 $ \[vlu,t,r] -> TLetD t UN (TPrm LOAD [vlu]) . TMatch t . MatchSum $ mapFromList - [ (0, ([BX], TAbs r $ TCon Ty.eitherRef 0 [r])) - , (1, ([BX], TAbs r $ TCon Ty.eitherRef 1 [r])) + [ (0, ([BX], TAbs r $ left r)) + , (1, ([BX], TAbs r $ right r)) ] value'create :: Var v => SuperNormal v @@ -792,7 +802,7 @@ standard'handle instr any'construct :: Var v => SuperNormal v any'construct = unop0 0 $ \[v] - -> TCon Ty.anyRef 0 [v] + -> TCon Ty.anyRef 0 [v] any'extract :: Var v => SuperNormal v any'extract @@ -967,20 +977,20 @@ inBxIomr arg1 arg2 fm result cont instr outMaybe :: forall v. Var v => v -> v -> ANormal v outMaybe maybe result = TMatch result . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs maybe $ TCon Ty.optionalRef 1 [maybe])) + [ (0, ([], none)) + , (1, ([BX], TAbs maybe $ some maybe)) ] outMaybeTup :: forall v. Var v => v -> v -> v -> v -> v -> v -> v -> ANormal v outMaybeTup a b n u bp p result = TMatch result . MatchSum $ mapFromList - [ (0, ([], TCon Ty.optionalRef 0 [])) + [ (0, ([], none)) , (1, ([UN,BX], TAbss [a,b] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD bp BX (TCon Ty.pairRef 0 [b,u]) . TLetD n BX (TCon Ty.natRef 0 [a]) . TLetD p BX (TCon Ty.pairRef 0 [n,bp]) - $ TCon Ty.optionalRef 1 [p])) + $ some p)) ] outIoFail :: forall v. Var v => v -> v -> v -> v -> ANormal v @@ -989,8 +999,8 @@ outIoFail stack1 stack2 fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) - , (1, ([BX], TAbs stack1 $ TCon eitherReference 1 [stack1])) + $ left fail) + , (1, ([BX], TAbs stack1 $ right stack1)) ] outIoFailNat :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -999,11 +1009,11 @@ outIoFailNat stack1 stack2 stack3 fail nat result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([UN],) . TAbs stack3 . TLetD nat BX (TCon Ty.natRef 0 [stack3]) - $ TCon eitherReference 1 [nat]) + $ right nat) ] outIoFailBox :: forall v. Var v => v -> v -> v -> v -> ANormal v @@ -1012,10 +1022,10 @@ outIoFailBox stack1 stack2 fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([BX],) . TAbs stack1 - $ TCon eitherReference 1 [stack1]) + $ right stack1) ] outIoFailUnit :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -1025,11 +1035,11 @@ outIoFailUnit stack1 stack2 stack3 unit fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([BX],) . TAbss [stack3] . TLetD unit BX (TCon Ty.unitRef 0 []) - $ TCon eitherReference 1 [unit]) + $ right unit) ] outIoFailBool :: forall v. Var v => v -> v -> v -> v -> v -> v -> ANormal v @@ -1039,11 +1049,11 @@ outIoFailBool stack1 stack2 stack3 bool fail result = [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([UN],) . TAbs stack3 . TLet (Indirect 1) bool BX (boolift stack3) - $ TCon eitherReference 1 [bool]) + $ right bool) ] outIoFailG @@ -1055,9 +1065,9 @@ outIoFailG stack1 stack2 fail result output k [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, k $ \t -> TLetD output BX t - $ TCon eitherReference 1 [output]) + $ right output) ] -- Input / Output glue @@ -1196,8 +1206,8 @@ boxToEFMBox = inBx arg result . outIoFailG stack1 stack2 fail result output $ \k -> ([UN], TAbs stack3 . TMatch stack3 . MatchSum $ mapFromList - [ (0, ([], k $ TCon Ty.optionalRef 0 [])) - , (1, ([BX], TAbs stack4 . k $ TCon Ty.optionalRef 1 [stack4])) + [ (0, ([], k $ none)) + , (1, ([BX], TAbs stack4 . k $ some stack4)) ]) where (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh8 @@ -1282,10 +1292,10 @@ natToEFUnit [ (0, ([BX, BX],) . TAbss [stack1, stack2] . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TCon eitherReference 0 [fail]) + $ left fail) , (1, ([],) . TLetD unit BX (TCon Ty.unitRef 0 []) - $ TCon eitherReference 1 [unit]) + $ right unit) ] where @@ -1299,8 +1309,8 @@ boxToEBoxBox instr . TLetD e UN (TFOp instr [b]) . TMatch e . MatchSum $ mapFromList - [ (0, ([BX], TAbs ev $ TCon eitherReference 0 [ev])) - , (1, ([BX], TAbs ev $ TCon eitherReference 1 [ev])) + [ (0, ([BX], TAbs ev $ left ev)) + , (1, ([BX], TAbs ev $ right ev)) ] where (e,b,ev) = fresh3 @@ -1570,10 +1580,10 @@ declareForeigns = do declareForeign "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h,bs) -> hPut h (Bytes.toArray bs) declareForeign "IO.systemTime.impl.v3" unitToEFNat - $ mkForeignIOF $ \() -> getPOSIXTime + $ mkForeignIOF $ \() -> getPOSIXTime declareForeign "IO.systemTimeMicroseconds.v1" unitToInt - $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime + $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime declareForeign "IO.getTempDirectory.impl.v3" unitToEFBox $ mkForeignIOF $ \() -> getTemporaryDirectory From d524b0a5a4af30fbe9d1c199f3bdc511d2ccb8a2 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 27 Sep 2021 13:12:33 -0400 Subject: [PATCH 129/148] some pattern-matching-related(?) fixes --- parser-typechecker/src/Unison/Runtime/ANF.hs | 6 +++--- parser-typechecker/src/Unison/Runtime/Builtin.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 09fb839024..163f6cd14e 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -103,7 +103,7 @@ import qualified Unison.Pattern as P import Unison.Reference (Reference(..)) import Unison.Referent (Referent) --- For internal errors +-- For internal errors data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) deriving (Show) instance Exception CompileExn @@ -1022,8 +1022,8 @@ anfBlock (Match' scrut cas) = do , pure . TMatch r $ MatchDataCover Ty.seqViewRef (EC.mapFromList - [ (0, ([], em)) - , (1, ([BX,BX], bd)) + [ (toEnum Ty.seqViewEmpty, ([], em)) + , (toEnum Ty.seqViewElem, ([BX,BX], bd)) ] ) ) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index d464dc9c71..15a636412c 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -935,9 +935,9 @@ inMaybeBx arg1 arg2 arg3 mb result cont instr = . TAbss [arg1, arg2] . TMatch arg1 . flip (MatchData Ty.optionalRef) Nothing $ mapFromList - [ (0, ([], TLetD mb UN (TLit $ I 0) + [ (toEnum Ty.noneId, ([], TLetD mb UN (TLit $ I 0) $ TLetD result UN (TFOp instr [mb, arg2]) cont)) - , (1, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) + , (toEnum Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) ] -- a -> b -> ... From 0711e35fdeaa8f10071521f3b650fe4a38ede84f Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 27 Sep 2021 12:51:36 -0500 Subject: [PATCH 130/148] Create release-steps.md --- docs/release-steps.md | 102 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 102 insertions(+) create mode 100644 docs/release-steps.md diff --git a/docs/release-steps.md b/docs/release-steps.md new file mode 100644 index 0000000000..9ec9976d68 --- /dev/null +++ b/docs/release-steps.md @@ -0,0 +1,102 @@ + +__0__ + +Communicate with core team - we are cutting a release now, are there any showstopping bugs that need fixing first? + +__1__ + +Create and push the tag to github. This will trigger the build. To determine the last release, check [the releases page](https://github.com/unisonweb/unison/releases). + +``` +git fetch +git checkout series/M2 +git merge origin/trunk +git tag -a $RELEASE_NAME -m "release" +``` + +__2__ + +Wait for the release to show up on [the releases page](https://github.com/unisonweb/unison/releases). This can take an hour or two! + +__3__ + +Create a release notes draft issue, following [this template](https://github.com/unisonweb/unison/issues/2342). + +__4__ + +Update trunk of `base` to include any new builtins added since last release. Suggestion for how to do this: look through the release notes draft to find the PRs merged since last release. + +``` +git log --oneline release/M2h...release/M2i | grep 'Merge pull request #' +``` + +Then just use `alias.term ##Nat.newBuiltin Nat.someName` and/or `alias.type ##SomeType SomeType`. I think this is probably better than doing `builtins.merge` at this point. + +__5__ + +Cut a release of base. + +``` +.> pull https://unisonweb/base basedev.release +.> cd basedev.release +.basedev> delete.namespace releases._latest +.basedev> squash trunk releases._ +.basedev> fork releases._ releases._latest +.basedev> push git@github.com/unisonweb/base +``` + +__6__ + +Update homebrew. + +``` +git clone git@github.com/unisonweb/homebrew-unison +``` + +Update this file: https://github.com/unisonweb/homebrew-unison/blob/master/unison-language.rb and change the version number and the path to the release. Leave the SHA alone, and then run `brew upgrade`. + +Do `brew upgrade unison-language`. It will tell you the SHA hash doesn't match. Update the file to use the hash it says. +Do the same for linux and mac - you can temporarily swap the mac / linux stanzas just to get the + +__7__ + +Merge and promote to production any PRs pending [on the docs site](https://github.com/unisonweb/unisonweb-org/pulls) which are associated with the new release. Confirm with @rlmark. + +__8__ + +Announce on #contrib Slack channel. Template below. + +--- + +Release announcement template - + +We've just released a new version of Unison, $RELEASE_NAME, release notes here (link to the issue). Install/upgrade instructions in the thread. + +Mac upgrade is just `brew upgrade unison-language`. + +A fresh install via: + +``` +brew tap unisonweb/unison +brew install unison-language +``` + +If you have previously done brew install unison-language --head to install a dev build, uninstall that first via brew uninstall unison-language. + +_Linux manual install:_ + +``` +mkdir unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/download/release%2FM2h/ucm-linux.tar.gz --output unisonlanguage/ucm.tar.gz +tar -xzf unisonlanguage/ucm.tar.gz -C unisonlanguage +./unisonlanguage/ucm +``` + +_Mac manual install:_ + +``` +mkdir unisonlanguage +curl -L https://github.com/unisonweb/unison/releases/download/release%2FM2h/ucm-macos.tar.gz --output unisonlanguage/ucm.tar.gz +tar -xzf unisonlanguage/ucm.tar.gz -C unisonlanguage +./unisonlanguage/ucm +``` From 2125e78e41eb421852f2ed7da71cf31bb857ee9f Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 27 Sep 2021 12:55:26 -0500 Subject: [PATCH 131/148] Update release-steps.md --- docs/release-steps.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/docs/release-steps.md b/docs/release-steps.md index 9ec9976d68..18e758072c 100644 --- a/docs/release-steps.md +++ b/docs/release-steps.md @@ -11,7 +11,8 @@ Create and push the tag to github. This will trigger the build. To determine the git fetch git checkout series/M2 git merge origin/trunk -git tag -a $RELEASE_NAME -m "release" +git tag -a release/$RELEASE_NAME -m "release" +git push origin release/$RELEASE_NAME ``` __2__ @@ -20,11 +21,11 @@ Wait for the release to show up on [the releases page](https://github.com/unison __3__ -Create a release notes draft issue, following [this template](https://github.com/unisonweb/unison/issues/2342). +Create a release notes draft issue, following [this template](https://github.com/unisonweb/unison/issues/2342) and updating the output of PRs merged and contributors to the release. __4__ -Update trunk of `base` to include any new builtins added since last release. Suggestion for how to do this: look through the release notes draft to find the PRs merged since last release. +Update trunk of `base` to include any new builtins added since last release. Suggestion for how to do this: look through the release notes draft to find the PRs merged since last release. @runarorma does this usually. ``` git log --oneline release/M2h...release/M2i | grep 'Merge pull request #' @@ -34,7 +35,7 @@ Then just use `alias.term ##Nat.newBuiltin Nat.someName` and/or `alias.type ##So __5__ -Cut a release of base. +Cut a release of base. @runarorama does this usually. ``` .> pull https://unisonweb/base basedev.release From 2aabad5fee6a66284b0d8881a1c2df804e8afe1c Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 11:30:51 -0700 Subject: [PATCH 132/148] Adds notes from conversations --- .../src/Unison/Codebase/Editor/Command.hs | 6 +++ .../Unison/Codebase/Editor/HandleCommand.hs | 21 +++++----- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 ++- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/InputOutput.hs | 1 + .../src/Unison/CommandLine/InputPattern.hs | 9 ++++ .../src/Unison/CommandLine/Welcome.hs | 41 +++++++++++-------- .../unison-parser-typechecker.cabal | 2 + 8 files changed, 58 insertions(+), 30 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index 1a260dd953..5929a14e9d 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -77,6 +77,10 @@ type TypecheckingResult v = Result (Seq (Note v Ann)) (Either Names0 (UF.TypecheckedUnisonFile v Ann)) +-- m is the IO monad that you're interpreting into?? +-- i is the type of the input. Input +-- v is used for unison types and terms - the Var type +-- a is the result of the command. So if it's a command that produces an Int, it's an Int. data Command m i v a where -- Escape hatch. Eval :: m a -> Command m i v a @@ -104,8 +108,10 @@ data Command m i v a where ConfigLookup :: Configured a => Text -> Command m i v (Maybe a) + -- THis one waits for the user to input something and returns a value of some type Input Input :: Command m i v i + -- RLM note: you should be able to combine Commands. InputWithOutput :: Command m i v i -> Output v -> Command m i v i -- Presents some output to the user diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index d542436906..52c2e63d2d 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -82,10 +82,10 @@ commandLine :: forall i v a gen . (Var v, Random.DRG gen) => Config - -> IO i -- RLM: await input + -> IO i -- RLM: await input -> (Branch IO -> IO ()) - -> Runtime v - -> (Output v -> IO ()) -- RLM: notify + -> Runtime v + -> (Output v -> IO ()) -- RLM: notify -> (NumberedOutput v -> IO NumberedArgs) -> (SourceName -> IO LoadSourceResult) -> Codebase IO v Ann @@ -96,6 +96,7 @@ commandLine commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen = flip State.evalStateT 0 . Free.fold go where + -- RLM note : think of the return type of this as just the IO x 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 @@ -104,17 +105,17 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour case serverBaseUrl of Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url) Nothing -> lift (return ()) - InputWithOutput input output -> do - -- RLM: not sure how exactly this is gonna work - let - fst = go input + InputWithOutput input output -> do + -- RLM: not sure how exactly this is gonna work + let + fst = go input snd = lift $ notifyUser output - - fst >>= snd + + fst >>= snd -- lift awaitInput >> \_ -> lift $ notifyUser output Input -> lift awaitInput Notify output -> lift $ notifyUser output - NotifyNumbered output -> lift $ notifyNumbered output + NotifyNumbered output -> lift $ notifyNumbered output ConfigLookup name -> lift $ Config.lookup config name LoadSource sourcePath -> lift $ loadSource sourcePath diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index f3ea9c5c97..50eb0e026a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -153,6 +153,9 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo(..)) type F m i v = Free (Command m i v) -- type (Action m i v) a +-- RLM Note: Action allows us to persist state and exit above what F will let you do. +-- Persists state between commands. - the state that it persists is the LoopState + type Action m i v = MaybeT (StateT (LoopState m v) (F m i v)) data LoopState m v @@ -201,6 +204,7 @@ defaultPatchNameSegment = "patch" prettyPrintEnvDecl :: Names -> Action' m v PPE.PrettyPrintEnvDecl prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns) +-- This returns an Action. loop :: forall m v . (Monad m, Var v) => Action m (Either Event Input) v () loop = do uf <- use latestTypecheckedFile @@ -332,7 +336,7 @@ loop = do else loadUnisonFile sourceName text Right input -> let - ifConfirmed = ifM (confirmedCommand input) + ifConfirmed = ifM (confirmedCommand input) -- RLM Note - maybe can copy this confirmed command state branchNotFound = respond . BranchNotFound branchNotFound' = respond . BranchNotFound . Path.unsplit' patchNotFound :: Path.Split' -> Action' m v () diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index d1fb86a22d..507d609c74 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -1,4 +1,4 @@ -module Unison.Codebase.Editor.Input +with module Unison.Codebase.Editor.Input where diff --git a/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs b/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs index a42ea9a641..b938fc0daa 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs @@ -86,6 +86,7 @@ data Input -- pairs onboarding input with desired output response -- | RespondToInput Input (Output String) -- RLM note: cycle happens here, also what is this type param? I chose an arbitrary type here and I know it shouldnt be a string. | RespondToInput Input OutputSimple -- RLM note: cycle happens here, also what is this type param? I chose an arbitrary type here and I know it shouldnt be a string. + -- RLM Note: Arya suggests not doing the above. Because why are we saving this if we can't do what we want cleanly. -- merge first causal into destination | MergeLocalBranchI Path' Path' Branch.MergeMode | PreviewMergeLocalBranchI Path' Path' diff --git a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs index 97542ddab0..4c6b77b9d4 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs @@ -22,6 +22,15 @@ data IsOptional | OnePlus -- 1 or more, at the end deriving Show +-- RLM note: Input pattern only triggers Input. +-- but how can an input pattern be triggered. +-- AI note: Haskeline takes keystrokes to [String] +-- InputPattern takes [String] to Input +-- HandleInput takes Input to Action (which is a monad that embeds Commands) +-- - One of the Commands is to `Notify` the user of some `Output` +-- HandleCommand takes individual `Command`s, does IO, and returns a result back to `HandleInput` +-- OutputMessages turns `Output` into `Pretty` + data InputPattern = InputPattern { patternName :: String , aliases :: [String] diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 98f8c8fc3d..281daf15ac 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -12,7 +12,7 @@ import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode -import Unison.Codebase.Editor.InputOutput +import Unison.Codebase.Editor.InputOutput import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) @@ -20,17 +20,20 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) -- import qualified Unison.Codebase.Editor.Input as Input --- IDEAS? +-- IDEAS? --- Notes: --- Download base should be quieter - the printout is annoyingly large. --- use more primitive IO functions for user input and git download. --- UX issue / design constraint: if we use existing input / output architecture, how will we constrain the user into only entering their authorship info? --- we don't want the user to have too much "freedom" when entering their author info. +-- Notes: +-- Download base should be quieter - the printout is annoyingly large. +-- use more primitive IO functions for user input and git download. +-- UX issue / design constraint: if we use existing input / output architecture, how will we constrain the user into only entering their authorship info? +-- we don't want the user to have too much "freedom" when entering their author info. +-- Take a look at the transcript parser as an example of how to issue commands that is not in main +-- Not sure about the empyt line to advance mechanic - how might we handle that with input/actions +-- Another idea: -- 1) --- * Refactor existing IO command loop out of main function - see notes in CommandLine.main --- * In Welcome.run; use existing interpreter to run commands +-- * Refactor existing IO command loop out of main function - see notes in CommandLine.main +-- * In Welcome.run; use existing interpreter to run commands -- * Implement a silencing mechanism -- 2) @@ -54,11 +57,12 @@ data CodebaseInitStatus data Onboarding = Init CodebaseInitStatus -- Can transition to [Base, Author, Finished, PreviouslyOnboarded] | Base BaseSteps -- Can transition to [Author, Finished] - | Author -- Can traisition to [Finished] + | Author -- Can transition to [Finished] -- End States | Finished | PreviouslyOnboarded +-- AI: Onboarding -> Action m v () -- ucm start -- create codebase @@ -92,23 +96,24 @@ welcome downloadBase newCodebasePath watchDir unisonVersion = Just path -> Welcome (Init (NewlyCreatedCodebase path)) downloadBase newCodebasePath watchDir unisonVersion Nothing -> Welcome (Init PreviouslyCreatedCodebase) downloadBase newCodebasePath watchDir unisonVersion --- remove IO +-- remove IO pullBase :: ReadRemoteNamespace -> IO (Either Event Input) pullBase _ns = let seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} - pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete + pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete output = Onboarding " THIS IS A TEST OF PULLING BASE!!" - in + in pure $ Right (RespondToInput pullRemote output) run :: Codebase IO v a -> Welcome -> IO [Either Event Input] run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do go onboarding [] where - go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] + go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] -- try + -- consider: go :: Onboarding -> Action IO v () go onboarding acc = case onboarding of Init (NewlyCreatedCodebase path) -> do @@ -141,14 +146,14 @@ run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, wat Base (DownloadBaseFailed _ _) -> do PT.putPrettyLn "Download Failed" getStarted dir >>= PT.putPrettyLn - pure acc + pure acc Author -> do PT.putPrettyLn "Enter your author!" - go Finished acc - Finished -> do + go Finished acc + Finished -> do getStarted dir >>= PT.putPrettyLn pure acc - PreviouslyOnboarded -> do + PreviouslyOnboarded -> do getStarted dir >>= PT.putPrettyLn pure acc diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 1dec98b567..31db97e44f 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -45,6 +45,7 @@ library Unison.Codebase.Editor.HandleCommand Unison.Codebase.Editor.HandleInput Unison.Codebase.Editor.Input + Unison.Codebase.Editor.InputOutput Unison.Codebase.Editor.Output Unison.Codebase.Editor.Output.BranchDiff Unison.Codebase.Editor.Output.DumpNamespace @@ -90,6 +91,7 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.CommandLine.WelcomeInputQueue Unison.DeclPrinter Unison.FileParser Unison.FileParsers From 6e80e02665eb2a9dd98c20c9820bbef598f67d7c Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 15:55:20 -0700 Subject: [PATCH 133/148] Adds pull.silent command and links it to existing output silencing mechanism so initial codebase download is less noisy --- .../src/Unison/Codebase/Editor/HandleInput.hs | 23 ++-- .../src/Unison/Codebase/Editor/Input.hs | 3 +- .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/Codebase/Verbosity.hs | 4 + .../src/Unison/CommandLine/InputPatterns.hs | 115 ++++++++++-------- .../src/Unison/CommandLine/OutputMessages.hs | 5 +- .../src/Unison/CommandLine/Welcome.hs | 3 +- .../unison-parser-typechecker.cabal | 1 + 8 files changed, 92 insertions(+), 66 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/Verbosity.hs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 34108ff56a..e4ca370b9e 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -150,6 +150,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Unison.Codebase.Editor.AuthorInfo (AuthorInfo(..)) import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.Codebase.Verbosity (Verbosity(..)) type F m i v = Free (Command m i v) @@ -429,7 +430,7 @@ loop = do UpdateBuiltinsI -> "builtins.update" MergeBuiltinsI -> "builtins.merge" MergeIOBuiltinsI -> "builtins.mergeio" - PullRemoteBranchI orepo dest _syncMode -> + PullRemoteBranchI orepo dest _syncMode _ -> (Text.pack . InputPattern.patternName $ InputPatterns.patternFromInput input) <> " " @@ -740,7 +741,7 @@ loop = do if Branch.isEmpty srcb then branchNotFound src0 else do let err = Just $ MergeAlreadyUpToDate src0 dest0 - mergeBranchAndPropagateDefaultPatch mergeMode inputDescription err srcb (Just dest0) dest + mergeBranchAndPropagateDefaultPatch mergeMode inputDescription err srcb (Just dest0) dest PreviewMergeLocalBranchI src0 dest0 -> do let [src, dest] = resolveToAbsolute <$> [src0, dest0] @@ -1685,13 +1686,16 @@ loop = do makePrintNamesFromLabeled' (Patch.labeledDependencies patch) respond $ ListEdits patch ppe - PullRemoteBranchI mayRepo path syncMode -> unlessError do + PullRemoteBranchI mayRepo path syncMode verbosity -> unlessError do ns <- maybe (writePathToRead <$> resolveConfiguredGitUrl Pull path) pure mayRepo lift $ unlessGitError do b <- importRemoteBranch ns syncMode let msg = Just $ PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path - lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b (Just path) destAbs + let controlPathPrintout = case verbosity of + Default -> Just path + Silent -> Nothing + lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b controlPathPrintout destAbs PushRemoteBranchI mayRepo path syncMode -> do let srcAbs = resolveToAbsolute path @@ -2206,20 +2210,19 @@ unlessError' f ma = unlessError $ withExceptT f ma -- supply unchangedMessage if you want to display it if merge had no effect mergeBranchAndPropagateDefaultPatch :: (Monad m, Var v) => Branch.MergeMode -> InputDescription -> Maybe (Output v) -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v () -mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb dest0 dest = - ifM (mergeBranch mode inputDescription srcb dest0 dest) +mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb dest0 dest = + ifM (mergeBranch mode inputDescription srcb dest0 dest ) (loadPropagateDiffDefaultPatch inputDescription dest0 dest) (for_ unchangedMessage respond) where mergeBranch :: (Monad m, Var v) => - Branch.MergeMode -> InputDescription -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v Bool + Branch.MergeMode -> InputDescription -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v Bool mergeBranch mode inputDescription srcb dest0 dest = unsafeTime "Merge Branch" $ do destb <- getAt dest merged <- eval $ Merge mode srcb destb b <- updateAtM inputDescription dest (const $ pure merged) - for_ dest0 $ \dest0 -> - diffHelper (Branch.head destb) (Branch.head merged) >>= - respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) + for_ dest0 $ \dest0 -> diffHelper (Branch.head destb) (Branch.head merged) >>= + respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) -- rlm note pure b loadPropagateDiffDefaultPatch :: (Monad m, Var v) => diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 8f51773f61..ad9776ac45 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -21,6 +21,7 @@ import Unison.ShortHash (ShortHash) import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Codebase.SyncMode ( SyncMode ) +import Unison.Codebase.Verbosity import Unison.Name ( Name ) import Unison.NameSegment ( NameSegment ) @@ -52,7 +53,7 @@ data Input | MergeLocalBranchI Path' Path' Branch.MergeMode | PreviewMergeLocalBranchI Path' Path' | DiffNamespaceI Path' Path' -- old new - | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode + | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode Verbosity | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index 09d4495a57..e6a370b525 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -78,7 +78,7 @@ data NumberedOutput v | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) -- rlm note | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) @@ -101,7 +101,7 @@ data Output v | BadMainFunction String (Type v Ann) PPE.PrettyPrintEnv [Type v Ann] | BranchEmpty (Either ShortBranchHash Path') | BranchNotEmpty Path' - | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' + | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' -- rlm note | CreatedNewBranch Path.Absolute | BranchAlreadyExists Path' | PatchAlreadyExists Path.Split' diff --git a/parser-typechecker/src/Unison/Codebase/Verbosity.hs b/parser-typechecker/src/Unison/Codebase/Verbosity.hs new file mode 100644 index 0000000000..01d060ccd8 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/Verbosity.hs @@ -0,0 +1,4 @@ +module Unison.Codebase.Verbosity +where + +data Verbosity = Default | Silent deriving (Eq, Show) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index dc02bbaef0..e9a3ec08b6 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -46,6 +46,8 @@ import qualified Unison.Codebase.Editor.UriParser as UriParser import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import Data.Tuple.Extra (uncurry3) +import Unison.Codebase.Verbosity (Verbosity) +import qualified Unison.Codebase.Verbosity as Verbosity showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = P.lines [ @@ -709,49 +711,58 @@ resetRoot = InputPattern "reset-root" [] [(Required, pathArg)] pure $ Input.ResetRootI src _ -> Left (I.help resetRoot)) -pull :: InputPattern -pull = InputPattern - "pull" - [] - [(Optional, gitUrlArg), (Optional, pathArg)] - (P.lines - [ P.wrap - "The `pull` command merges a remote namespace into a local namespace." - , "" - , P.wrapColumn2 - [ ( "`pull remote local`" - , "merges the remote namespace `remote`" - <>"into the local namespace `local`." - ) - , ( "`pull remote`" - , "merges the remote namespace `remote`" - <>"into the current namespace") - , ( "`pull`" - , "merges the remote namespace configured in `.unisonConfig`" - <> "with the key `GitUrl.ns` where `ns` is the current namespace," - <> "into the current namespace") - ] - , "" - , P.wrap "where `remote` is a git repository, optionally followed by `:`" - <> "and an absolute remote path, such as:" - , P.indentN 2 . P.lines $ - [P.backticked "https://github.com/org/repo" - ,P.backticked "https://github.com/org/repo:.some.remote.path" - ] - ] - ) - (\case - [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit - [url] -> do - ns <- parseUri "url" url - Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit - [url, path] -> do - ns <- parseUri "url" url - p <- first fromString $ Path.parsePath' path - Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit - _ -> Left (I.help pull) - ) +pullSilent :: InputPattern +pullSilent = + pullImpl "pull.silent" Verbosity.Silent + +pull :: InputPattern +pull = pullImpl "pull" Verbosity.Default + +pullImpl :: [Char] -> Verbosity -> InputPattern +pullImpl name verbosity = self + where + self = InputPattern + name + [] + [(Optional, gitUrlArg), (Optional, pathArg)] + (P.lines + [ P.wrap + "The" <> makeExample' self <> "command merges a remote namespace into a local namespace." + , "" + , P.wrapColumn2 + [ ( makeExample self ["remote", "local"] + , "merges the remote namespace `remote`" + <>"into the local namespace `local" + ) + , ( makeExample self ["remote"] + , "merges the remote namespace `remote`" + <>"into the current namespace") + , ( makeExample' self + , "merges the remote namespace configured in `.unisonConfig`" + <> "with the key `GitUrl.ns` where `ns` is the current namespace," + <> "into the current namespace") + ] + , "" + , P.wrap "where `remote` is a git repository, optionally followed by `:`" + <> "and an absolute remote path, such as:" + , P.indentN 2 . P.lines $ + [P.backticked "https://github.com/org/repo" + ,P.backticked "https://github.com/org/repo:.some.remote.path" + ] + ] + ) + (\case + [] -> + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit verbosity + [url] -> do + ns <- parseUri "url" url + Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit verbosity + [url, path] -> do + ns <- parseUri "url" url + p <- first fromString $ Path.parsePath' path + Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit verbosity + _ -> Left (I.help pull) + ) pullExhaustive :: InputPattern pullExhaustive = InputPattern @@ -768,14 +779,14 @@ pullExhaustive = InputPattern ) (\case [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Verbosity.Default [url] -> do ns <- parseUri "url" url - Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete + Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Verbosity.Default [url, path] -> do ns <- parseUri "url" url p <- first fromString $ Path.parsePath' path - Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete + Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete Verbosity.Default _ -> Left (I.help pull) ) @@ -1399,6 +1410,7 @@ validInputs = , names , push , pull + , pullSilent , pushExhaustive , pullExhaustive , createPullRequest @@ -1552,6 +1564,9 @@ pathArg :: ArgumentType pathArg = ArgumentType "namespace" $ pathCompletor exactComplete (Set.map Path.toText . Branch.deepPaths) +verbosityArg :: ArgumentType +verbosityArg = ArgumentType "verbosity" $ \q _ _ _ -> pure (exactComplete q ["default", "silent"]) + newNameArg :: ArgumentType newNameArg = ArgumentType "new-name" $ pathCompletor prefixIncomplete @@ -1577,10 +1592,10 @@ collectNothings f as = [ a | (Nothing, a) <- map f as `zip` as ] patternFromInput :: Input -> InputPattern patternFromInput = \case - Input.PushRemoteBranchI _ _ SyncMode.ShortCircuit -> push + Input.PushRemoteBranchI _ _ SyncMode.ShortCircuit -> push Input.PushRemoteBranchI _ _ SyncMode.Complete -> pushExhaustive - Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit -> pull - Input.PullRemoteBranchI _ _ SyncMode.Complete -> pushExhaustive + Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit _ -> pull + Input.PullRemoteBranchI _ _ SyncMode.Complete _ -> pushExhaustive _ -> error "todo: finish this function" inputStringFromInput :: IsString s => Input -> P.Pretty s @@ -1589,7 +1604,7 @@ inputStringFromInput = \case (P.string . I.patternName $ patternFromInput i) <> (" " <> maybe mempty (P.text . uncurry RemoteRepo.printHead) rh) <> " " <> P.shown p' - i@(Input.PullRemoteBranchI ns p' _) -> + i@(Input.PullRemoteBranchI ns p' _ _) -> (P.string . I.patternName $ patternFromInput i) <> (" " <> maybe mempty (P.text . uncurry3 RemoteRepo.printNamespace) ns) <> " " <> P.shown p' diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 182b9a3e6f..ca67f62db9 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -150,6 +150,7 @@ notifyNumbered o = case o of , undoTip ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) + -- rlm note: ShowDiffAfterModifyBranch b' _ _ (OBD.isEmpty -> True) -> (P.wrap $ "Nothing changed in" <> prettyPath' b' <> ".", mempty) ShowDiffAfterModifyBranch b' bAbs ppe diff -> @@ -159,11 +160,11 @@ notifyNumbered o = case o of , p , "" , undoTip - ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) + ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) -- rlm note change ShowDiffAfterMerge _ _ _ (OBD.isEmpty -> True) -> (P.wrap $ "Nothing changed as a result of the merge.", mempty) - ShowDiffAfterMerge dest' destAbs ppe diffOutput -> + ShowDiffAfterMerge dest' destAbs ppe diffOutput -> -- rlm note: HERE silence first (\p -> P.lines [ P.wrap $ "Here's what's changed in " <> prettyPath' dest' <> "after the merge:" , "" diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index e593f18a7a..a0aa317576 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -13,6 +13,7 @@ import Unison.Codebase.Editor.Input (Input (..), Event) import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import qualified Unison.Codebase.Verbosity as Verbosity -- Should Welcome include whether or not the codebase was created just now? @@ -82,7 +83,7 @@ pullBase ns = do seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} - PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete + PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent asciiartUnison :: P.Pretty P.ColorText asciiartUnison = diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index f5953ba2c5..66a3da4b33 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -81,6 +81,7 @@ library Unison.Codebase.TranscriptParser Unison.Codebase.Type Unison.Codebase.TypeEdit + Unison.Codebase.Verbosity Unison.Codebase.Watch Unison.CodebasePath Unison.CommandLine From 8a421d1db579ad99d62d6f907edc2927182381bd Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 16:01:36 -0700 Subject: [PATCH 134/148] removes extra whitespaces, notes --- .../src/Unison/Codebase/Editor/HandleInput.hs | 17 +++++++++-------- .../src/Unison/Codebase/Editor/Output.hs | 4 ++-- .../src/Unison/CommandLine/OutputMessages.hs | 2 +- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index e4ca370b9e..87fa89afe4 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -741,7 +741,7 @@ loop = do if Branch.isEmpty srcb then branchNotFound src0 else do let err = Just $ MergeAlreadyUpToDate src0 dest0 - mergeBranchAndPropagateDefaultPatch mergeMode inputDescription err srcb (Just dest0) dest + mergeBranchAndPropagateDefaultPatch mergeMode inputDescription err srcb (Just dest0) dest PreviewMergeLocalBranchI src0 dest0 -> do let [src, dest] = resolveToAbsolute <$> [src0, dest0] @@ -1692,10 +1692,10 @@ loop = do b <- importRemoteBranch ns syncMode let msg = Just $ PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path - let controlPathPrintout = case verbosity of + let printDiffPath = case verbosity of Default -> Just path Silent -> Nothing - lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b controlPathPrintout destAbs + lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b printDiffPath destAbs PushRemoteBranchI mayRepo path syncMode -> do let srcAbs = resolveToAbsolute path @@ -2210,19 +2210,20 @@ unlessError' f ma = unlessError $ withExceptT f ma -- supply unchangedMessage if you want to display it if merge had no effect mergeBranchAndPropagateDefaultPatch :: (Monad m, Var v) => Branch.MergeMode -> InputDescription -> Maybe (Output v) -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v () -mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb dest0 dest = - ifM (mergeBranch mode inputDescription srcb dest0 dest ) +mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb dest0 dest = + ifM (mergeBranch mode inputDescription srcb dest0 dest) (loadPropagateDiffDefaultPatch inputDescription dest0 dest) (for_ unchangedMessage respond) where mergeBranch :: (Monad m, Var v) => - Branch.MergeMode -> InputDescription -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v Bool + Branch.MergeMode -> InputDescription -> Branch m -> Maybe Path.Path' -> Path.Absolute -> Action' m v Bool mergeBranch mode inputDescription srcb dest0 dest = unsafeTime "Merge Branch" $ do destb <- getAt dest merged <- eval $ Merge mode srcb destb b <- updateAtM inputDescription dest (const $ pure merged) - for_ dest0 $ \dest0 -> diffHelper (Branch.head destb) (Branch.head merged) >>= - respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) -- rlm note + for_ dest0 $ \dest0 -> + diffHelper (Branch.head destb) (Branch.head merged) >>= + respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) pure b loadPropagateDiffDefaultPatch :: (Monad m, Var v) => diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index e6a370b525..09d4495a57 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -78,7 +78,7 @@ data NumberedOutput v | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) -- rlm note + | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) @@ -101,7 +101,7 @@ data Output v | BadMainFunction String (Type v Ann) PPE.PrettyPrintEnv [Type v Ann] | BranchEmpty (Either ShortBranchHash Path') | BranchNotEmpty Path' - | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' -- rlm note + | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' | CreatedNewBranch Path.Absolute | BranchAlreadyExists Path' | PatchAlreadyExists Path.Split' diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index ca67f62db9..e3d8a9b666 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -160,7 +160,7 @@ notifyNumbered o = case o of , p , "" , undoTip - ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) -- rlm note change + ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) ShowDiffAfterMerge _ _ _ (OBD.isEmpty -> True) -> (P.wrap $ "Nothing changed as a result of the merge.", mempty) From e9a6fa7594b0084728e84a08ebd4ec9645c5eb98 Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 16:38:17 -0700 Subject: [PATCH 135/148] updates help text to reference self, more whitespace --- .../src/Unison/Codebase/Editor/HandleInput.hs | 8 ++-- .../src/Unison/Codebase/Verbosity.hs | 7 +++- .../src/Unison/CommandLine/InputPatterns.hs | 38 +++++++++---------- 3 files changed, 28 insertions(+), 25 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 87fa89afe4..fec2c7c446 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -150,7 +150,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Unison.Codebase.Editor.AuthorInfo (AuthorInfo(..)) import qualified Unison.Hashing.V2.Convert as Hashing -import Unison.Codebase.Verbosity (Verbosity(..)) +import qualified Unison.Codebase.Verbosity as Verbosity type F m i v = Free (Command m i v) @@ -1692,9 +1692,7 @@ loop = do b <- importRemoteBranch ns syncMode let msg = Just $ PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path - let printDiffPath = case verbosity of - Default -> Just path - Silent -> Nothing + let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path lift $ mergeBranchAndPropagateDefaultPatch Branch.RegularMerge inputDescription msg b printDiffPath destAbs PushRemoteBranchI mayRepo path syncMode -> do @@ -2222,7 +2220,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb merged <- eval $ Merge mode srcb destb b <- updateAtM inputDescription dest (const $ pure merged) for_ dest0 $ \dest0 -> - diffHelper (Branch.head destb) (Branch.head merged) >>= + diffHelper (Branch.head destb) (Branch.head merged) >>= respondNumbered . uncurry (ShowDiffAfterMerge dest0 dest) pure b diff --git a/parser-typechecker/src/Unison/Codebase/Verbosity.hs b/parser-typechecker/src/Unison/Codebase/Verbosity.hs index 01d060ccd8..67dee2b532 100644 --- a/parser-typechecker/src/Unison/Codebase/Verbosity.hs +++ b/parser-typechecker/src/Unison/Codebase/Verbosity.hs @@ -1,4 +1,9 @@ module Unison.Codebase.Verbosity where -data Verbosity = Default | Silent deriving (Eq, Show) \ No newline at end of file +data Verbosity = Default | Silent deriving (Eq, Show) + +isSilent :: Verbosity -> Bool +isSilent v = case v of + Default -> False + Silent -> True diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index e9a3ec08b6..cde5f2ae7b 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -711,33 +711,35 @@ resetRoot = InputPattern "reset-root" [] [(Required, pathArg)] pure $ Input.ResetRootI src _ -> Left (I.help resetRoot)) -pullSilent :: InputPattern -pullSilent = +pullSilent :: InputPattern +pullSilent = pullImpl "pull.silent" Verbosity.Silent -pull :: InputPattern -pull = pullImpl "pull" Verbosity.Default +pull :: InputPattern +pull = pullImpl "pull" Verbosity.Default pullImpl :: [Char] -> Verbosity -> InputPattern -pullImpl name verbosity = self - where - self = InputPattern +pullImpl name verbosity = do + self + where + addendum = if Verbosity.isSilent verbosity then "without listing the merged entities" else "" + self = InputPattern name [] [(Optional, gitUrlArg), (Optional, pathArg)] (P.lines [ P.wrap - "The" <> makeExample' self <> "command merges a remote namespace into a local namespace." + "The" <> makeExample' self <> "command merges a remote namespace into a local namespace" <> addendum , "" , P.wrapColumn2 [ ( makeExample self ["remote", "local"] , "merges the remote namespace `remote`" - <>"into the local namespace `local" + <>"into the local namespace `local" ) , ( makeExample self ["remote"] , "merges the remote namespace `remote`" <>"into the current namespace") - , ( makeExample' self + , ( makeExample' self , "merges the remote namespace configured in `.unisonConfig`" <> "with the key `GitUrl.ns` where `ns` is the current namespace," <> "into the current namespace") @@ -753,15 +755,15 @@ pullImpl name verbosity = self ) (\case [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit verbosity + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit verbosity [url] -> do ns <- parseUri "url" url - Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit verbosity + Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit verbosity [url, path] -> do ns <- parseUri "url" url p <- first fromString $ Path.parsePath' path Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit verbosity - _ -> Left (I.help pull) + _ -> Left (I.help self) ) pullExhaustive :: InputPattern @@ -779,7 +781,7 @@ pullExhaustive = InputPattern ) (\case [] -> - Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Verbosity.Default + Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Verbosity.Default [url] -> do ns <- parseUri "url" url Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Verbosity.Default @@ -1564,9 +1566,6 @@ pathArg :: ArgumentType pathArg = ArgumentType "namespace" $ pathCompletor exactComplete (Set.map Path.toText . Branch.deepPaths) -verbosityArg :: ArgumentType -verbosityArg = ArgumentType "verbosity" $ \q _ _ _ -> pure (exactComplete q ["default", "silent"]) - newNameArg :: ArgumentType newNameArg = ArgumentType "new-name" $ pathCompletor prefixIncomplete @@ -1592,9 +1591,10 @@ collectNothings f as = [ a | (Nothing, a) <- map f as `zip` as ] patternFromInput :: Input -> InputPattern patternFromInput = \case - Input.PushRemoteBranchI _ _ SyncMode.ShortCircuit -> push + Input.PushRemoteBranchI _ _ SyncMode.ShortCircuit -> push Input.PushRemoteBranchI _ _ SyncMode.Complete -> pushExhaustive - Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit _ -> pull + Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit Verbosity.Default -> pull + Input.PullRemoteBranchI _ _ SyncMode.ShortCircuit Verbosity.Silent -> pullSilent Input.PullRemoteBranchI _ _ SyncMode.Complete _ -> pushExhaustive _ -> error "todo: finish this function" From 170a4cc135a8f8de2d784a1f14a61f9b7c766887 Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 16:39:48 -0700 Subject: [PATCH 136/148] removing more notes --- parser-typechecker/src/Unison/Codebase/Init.hs | 2 +- parser-typechecker/src/Unison/CommandLine/OutputMessages.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index cc9784d1b5..8530f02396 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -139,6 +139,6 @@ openNewUcmCodebaseOrExit cbInit debugName path = do pure x -- | try to init a codebase where none exists and then exit regardless (i.e. `ucm -codebase dir init`) -initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () -- RLM : or could change here +initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () initCodebaseAndExit i debugName mdir = void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index e3d8a9b666..182b9a3e6f 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -150,7 +150,6 @@ notifyNumbered o = case o of , undoTip ]) (showDiffNamespace ShowNumbers ppe bAbs bAbs diff) - -- rlm note: ShowDiffAfterModifyBranch b' _ _ (OBD.isEmpty -> True) -> (P.wrap $ "Nothing changed in" <> prettyPath' b' <> ".", mempty) ShowDiffAfterModifyBranch b' bAbs ppe diff -> @@ -164,7 +163,7 @@ notifyNumbered o = case o of ShowDiffAfterMerge _ _ _ (OBD.isEmpty -> True) -> (P.wrap $ "Nothing changed as a result of the merge.", mempty) - ShowDiffAfterMerge dest' destAbs ppe diffOutput -> -- rlm note: HERE silence + ShowDiffAfterMerge dest' destAbs ppe diffOutput -> first (\p -> P.lines [ P.wrap $ "Here's what's changed in " <> prettyPath' dest' <> "after the merge:" , "" From 081bc87ce5b40eebbb56cf70d582539c2bca556d Mon Sep 17 00:00:00 2001 From: rlmark Date: Mon, 27 Sep 2021 17:10:05 -0700 Subject: [PATCH 137/148] changes [Char] to string, adds a few pull.silent commands to existing tests --- parser-typechecker/src/Unison/CommandLine/InputPatterns.hs | 2 +- parser-typechecker/tests/Unison/Test/GitSync.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index cde5f2ae7b..4018a8f265 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -718,7 +718,7 @@ pullSilent = pull :: InputPattern pull = pullImpl "pull" Verbosity.Default -pullImpl :: [Char] -> Verbosity -> InputPattern +pullImpl :: String -> Verbosity -> InputPattern pullImpl name verbosity = do self where diff --git a/parser-typechecker/tests/Unison/Test/GitSync.hs b/parser-typechecker/tests/Unison/Test/GitSync.hs index 1b81613e21..64e36fd2bd 100644 --- a/parser-typechecker/tests/Unison/Test/GitSync.hs +++ b/parser-typechecker/tests/Unison/Test/GitSync.hs @@ -132,7 +132,7 @@ test = scope "gitsync22" . tests $ |]) (\repo -> [i| ```ucm - .> pull ${repo} + .> pull.silent ${repo} .> find ``` ```unison @@ -168,7 +168,7 @@ test = scope "gitsync22" . tests $ |]) (\repo -> [i| ```ucm - .> pull ${repo} + .> pull.silent ${repo} .> view.patch patch ``` |]) From 0c6b1b7a9d88e9614d199fe2d19738e16048fdd0 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 27 Sep 2021 19:14:13 -0500 Subject: [PATCH 138/148] Update release-steps.md --- docs/release-steps.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/docs/release-steps.md b/docs/release-steps.md index 18e758072c..27c0071036 100644 --- a/docs/release-steps.md +++ b/docs/release-steps.md @@ -40,10 +40,10 @@ Cut a release of base. @runarorama does this usually. ``` .> pull https://unisonweb/base basedev.release .> cd basedev.release -.basedev> delete.namespace releases._latest -.basedev> squash trunk releases._ -.basedev> fork releases._ releases._latest -.basedev> push git@github.com/unisonweb/base +.basedev.release> delete.namespace releases._latest +.basedev.release> squash trunk releases._ +.basedev.release> fork releases._ releases._latest +.basedev.release> push git@github.com/unisonweb/base ``` __6__ From 699094097f0fae6f98f3285ff2893fd9c9507267 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Mon, 27 Sep 2021 21:08:39 -0400 Subject: [PATCH 139/148] Update release-steps.md --- docs/release-steps.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/release-steps.md b/docs/release-steps.md index 27c0071036..4e8b1f111e 100644 --- a/docs/release-steps.md +++ b/docs/release-steps.md @@ -57,7 +57,7 @@ git clone git@github.com/unisonweb/homebrew-unison Update this file: https://github.com/unisonweb/homebrew-unison/blob/master/unison-language.rb and change the version number and the path to the release. Leave the SHA alone, and then run `brew upgrade`. Do `brew upgrade unison-language`. It will tell you the SHA hash doesn't match. Update the file to use the hash it says. -Do the same for linux and mac - you can temporarily swap the mac / linux stanzas just to get the +Do the same for linux and mac - you can temporarily swap the mac / linux stanzas just to get the value for the other platform. __7__ From 4d4dd787581822ea10d0cca21eeed7ed48a7aa16 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 28 Sep 2021 11:40:11 -0700 Subject: [PATCH 140/148] wip --- parser-typechecker/src/Unison/CommandLine/Welcome.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 281daf15ac..b5bb65b71a 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -104,9 +104,8 @@ pullBase _ns = rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete - output = Onboarding " THIS IS A TEST OF PULLING BASE!!" in - pure $ Right (RespondToInput pullRemote output) + pure $ Right (pullRemote) run :: Codebase IO v a -> Welcome -> IO [Either Event Input] run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do From 128d6eebbc07ecd99b3b2391bb437e3e747625aa Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 28 Sep 2021 12:25:58 -0700 Subject: [PATCH 141/148] wip typecheck point --- .../src/Unison/Codebase/Editor/Command.hs | 12 +- .../Unison/Codebase/Editor/HandleCommand.hs | 8 - .../src/Unison/Codebase/Editor/HandleInput.hs | 9 +- .../src/Unison/Codebase/Editor/Input.hs | 45 +- .../src/Unison/Codebase/Editor/InputOutput.hs | 483 ------------- .../src/Unison/Codebase/Editor/Output.hs | 659 +++++++++--------- parser-typechecker/src/Unison/CommandLine.hs | 2 +- .../src/Unison/CommandLine/InputPattern.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 17 +- .../src/Unison/CommandLine/Welcome.hs | 4 +- .../unison-parser-typechecker.cabal | 1 - 11 files changed, 391 insertions(+), 851 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index 5929a14e9d..e03ab12f82 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -26,8 +26,7 @@ import Unison.Server.Backend ( DefinitionResults import Data.Configurator.Types ( Configured ) import qualified Data.Map as Map --- import Unison.Codebase.Editor.Output -import Unison.Codebase.Editor.InputOutput +import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Branch ( Branch ) @@ -65,8 +64,8 @@ import qualified Unison.WatchKind as WK import Unison.Codebase.Type (GitError) type AmbientAbilities v = [Type v Ann] --- type SourceName = Text --- type Source = Text +type SourceName = Text +type Source = Text type LexedSource = (Text, [L.Token L.Lexeme]) data LoadSourceResult = InvalidSourceNameError @@ -108,12 +107,8 @@ data Command m i v a where ConfigLookup :: Configured a => Text -> Command m i v (Maybe a) - -- THis one waits for the user to input something and returns a value of some type Input Input :: Command m i v i - -- RLM note: you should be able to combine Commands. - InputWithOutput :: Command m i v i -> Output v -> Command m i v i - -- Presents some output to the user Notify :: Output v -> Command m i v () NotifyNumbered :: NumberedOutput v -> Command m i v NumberedArgs @@ -262,7 +257,6 @@ commandName = \case UI -> "UI" ConfigLookup{} -> "ConfigLookup" Input -> "Input" - InputWithOutput{} -> "Input" Notify{} -> "Notify" NotifyNumbered{} -> "NotifyNumbered" AddDefsToCodebase{} -> "AddDefsToCodebase" diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index 1fbe17369d..c2111a273c 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -102,14 +102,6 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour case serverBaseUrl of Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url) Nothing -> lift (return ()) - InputWithOutput input output -> do - -- RLM: not sure how exactly this is gonna work - let - fst = go input - snd = lift $ notifyUser output - - fst >>= snd - -- lift awaitInput >> \_ -> lift $ notifyUser output Input -> lift awaitInput Notify output -> lift $ notifyUser output NotifyNumbered output -> lift $ notifyNumbered output diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 00891ac251..91b8d49d91 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -28,9 +28,9 @@ import Unison.Server.Backend (ShallowListEntry(..), TermEntry(..), TypeEntry(..) import qualified Unison.Codebase.MainTerm as MainTerm import Unison.Codebase.Editor.Command as Command import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.InputOutput +import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.DisplayObject -import qualified Unison.Codebase.Editor.InputOutput as Output +import qualified Unison.Codebase.Editor.Output as Output import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) import qualified Unison.Codebase.Editor.SlurpResult as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..)) @@ -443,6 +443,7 @@ loop = do (uncurry3 printNamespace) orepo <> " " <> p' dest + CreateMessage{}-> wat LoadI{} -> wat PreviewAddI{} -> wat PreviewUpdateI{} -> wat @@ -679,6 +680,10 @@ loop = do doDisplay outputLoc ns tm in case input of + + CreateMessage pretty -> + respond $ PrintMessage pretty + ShowReflogI -> do entries <- convertEntries Nothing [] <$> eval LoadReflog numberedArgs .= diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 610fd3319f..58924d73fa 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -1,5 +1,14 @@ -with module Unison.Codebase.Editor.Input -where + +module Unison.Codebase.Editor.Input + ( Input(..) + , Event(..) + , OutputLocation(..) + , PatchPath + , BranchId, parseBranchId + , HashOrHQSplit' + ) where + +import Unison.Prelude import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch @@ -13,9 +22,28 @@ import Unison.ShortHash (ShortHash) import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Codebase.SyncMode ( SyncMode ) -import Unison.Codebase.Verbosity import Unison.Name ( Name ) import Unison.NameSegment ( NameSegment ) +import qualified Unison.Util.Pretty as P +import Unison.Codebase.Verbosity + +import qualified Data.Text as Text + +data Event + = UnisonFileChanged SourceName Source + | IncomingRootBranch (Set Branch.Hash) + +type Source = Text -- "id x = x\nconst a b = a" +type SourceName = Text -- "foo.u" or "buffer 7" +type PatchPath = Path.Split' +type BranchId = Either ShortBranchHash Path' +type HashOrHQSplit' = Either ShortHash Path.HQSplit' + +parseBranchId :: String -> Either String BranchId +parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of + Nothing -> Left "Invalid hash, expected a base32hex string." + Just h -> pure $ Left h +parseBranchId s = Right <$> Path.parsePath' s data Input -- names stuff: @@ -34,6 +62,8 @@ data Input | ResetRootI (Either ShortBranchHash Path') -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? + -- CreateMessage is used in Welcome module to instruct user + | CreateMessage (P.Pretty P.ColorText) -- change directory | SwitchBranchI Path' | UpI @@ -118,4 +148,11 @@ data Input | QuitI | UiI deriving (Eq, Show) - \ No newline at end of file + +-- Some commands, like `view`, can dump output to either console or a file. +data OutputLocation + = ConsoleLocation + | LatestFileLocation + | FileLocation FilePath + -- ClipboardLocation + deriving (Eq, Show) \ No newline at end of file diff --git a/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs b/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs deleted file mode 100644 index dd072d9087..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Editor/InputOutput.hs +++ /dev/null @@ -1,483 +0,0 @@ - -{-# LANGUAGE StandaloneDeriving #-} -- RLM: Not sure exactly - - -module Unison.Codebase.Editor.InputOutput -where - -import Unison.Prelude - -import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Branch.Merge as Branch -import qualified Unison.HashQualified as HQ -import qualified Unison.HashQualified' as HQ' -import Unison.Codebase.Path ( Path' ) -import qualified Unison.Codebase.Path as Path -import qualified Unison.Codebase.Path.Parse as Path -import Unison.Codebase.Editor.RemoteRepo -import Unison.ShortHash (ShortHash) -import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.ShortBranchHash as SBH -import Unison.Codebase.SyncMode ( SyncMode ) -import Unison.Name ( Name ) -import Unison.NameSegment ( NameSegment ) - -import qualified Data.Text as Text - - ---- - -import Unison.Server.Backend (ShallowListEntry(..)) -import Unison.Codebase (GetRootBranchError) -import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) -import Unison.Codebase.Patch (Patch) -import Unison.Codebase.Type (GitError) -import Unison.Names2 ( Names ) -import Unison.Parser.Ann (Ann) -import qualified Unison.Reference as Reference -import Unison.Reference ( Reference ) -import Unison.Referent ( Referent ) -import Unison.DataDeclaration ( Decl ) -import Unison.Util.Relation (Relation) -import qualified Unison.Codebase.Editor.SlurpResult as SR -import qualified Unison.Codebase.Metadata as Metadata -import qualified Unison.Codebase.Runtime as Runtime -import qualified Unison.Parser as Parser -import qualified Unison.PrettyPrintEnv as PPE -import qualified Unison.PrettyPrintEnvDecl as PPE -import qualified Unison.Typechecker.Context as Context -import qualified Unison.UnisonFile as UF -import qualified Unison.Util.Pretty as P -import Unison.Codebase.Editor.DisplayObject (DisplayObject) -import qualified Unison.Codebase.Editor.TodoOutput as TO -import Unison.Server.SearchResult' (SearchResult') -import Unison.Term (Term) -import Unison.Type (Type) -import qualified Unison.Names.ResolutionResult as Names -import qualified Unison.Names3 as Names -import qualified Data.Set as Set -import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) -import Unison.LabeledDependency (LabeledDependency) -import qualified Unison.WatchKind as WK - --- EVERYTHING FROM INPUT -data Event - = UnisonFileChanged SourceName Source - | IncomingRootBranch (Set Branch.Hash) - -type Source = Text -- "id x = x\nconst a b = a" -type SourceName = Text -- "foo.u" or "buffer 7" -type BranchId = Either ShortBranchHash Path' -type HashOrHQSplit' = Either ShortHash Path.HQSplit' -type PatchPath = Path.Split' - -parseBranchId :: String -> Either String BranchId -parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of - Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> pure $ Left h -parseBranchId s = Right <$> Path.parsePath' s - -data Input - -- names stuff: - -- directory ops - -- `Link` must describe a repo and a source path within that repo. - -- clone w/o merge, error if would clobber - = ForkLocalBranchI (Either ShortBranchHash Path') Path' - | CreateMessage (P.Pretty P.ColorText) - -- RLM Note: Arya suggests not doing the above. Because why are we saving this if we can't do what we want cleanly. - -- merge first causal into destination - | MergeLocalBranchI Path' Path' Branch.MergeMode - | PreviewMergeLocalBranchI Path' Path' - | DiffNamespaceI Path' Path' -- old new - | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode - | PushRemoteBranchI (Maybe WriteRemotePath) Path' SyncMode - | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace - | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' - | ResetRootI (Either ShortBranchHash Path') - -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? - -- Does it make sense to fork from not-the-root of a Github repo? - -- change directory - | SwitchBranchI Path' - | UpI - | PopBranchI - -- > names foo - -- > names foo.bar - -- > names .foo.bar - -- > names .foo.bar#asdflkjsdf - -- > names #sdflkjsdfhsdf - | NamesI (HQ.HashQualified Name) - | AliasTermI HashOrHQSplit' Path.Split' - | AliasTypeI HashOrHQSplit' Path.Split' - | AliasManyI [Path.HQSplit] Path' - -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. - | MoveTermI Path.HQSplit' Path.Split' - | MoveTypeI Path.HQSplit' Path.Split' - | MoveBranchI (Maybe Path.Split') Path.Split' - | MovePatchI Path.Split' Path.Split' - | CopyPatchI Path.Split' Path.Split' - -- delete = unname - | DeleteI Path.HQSplit' - | DeleteTermI Path.HQSplit' - | DeleteTypeI Path.HQSplit' - | DeleteBranchI (Maybe Path.Split') - | DeletePatchI Path.Split' - -- resolving naming conflicts within `branchpath` - -- Add the specified name after deleting all others for a given reference - -- within a given branch. - | ResolveTermNameI Path.HQSplit' - | ResolveTypeNameI Path.HQSplit' - -- edits stuff: - | LoadI (Maybe FilePath) - | 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' - | ReplaceI (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 - | HistoryI (Maybe Int) (Maybe Int) BranchId - -- execute an IO thunk - | ExecuteI String - -- execute an IO [Result] - | IOTestI (HQ.HashQualified Name) - | TestI Bool Bool -- TestI showSuccesses showFailures - -- metadata - -- `link metadata definitions` (adds metadata to all of `definitions`) - | LinkI (HQ.HashQualified Name) [Path.HQSplit'] - -- `unlink metadata definitions` (removes metadata from all of `definitions`) - | UnlinkI (HQ.HashQualified Name) [Path.HQSplit'] - -- links from - | LinksI Path.HQSplit' (Maybe String) - | CreateAuthorI NameSegment {- identifier -} Text {- name -} - | DisplayI OutputLocation (HQ.HashQualified Name) - | DocsI Path.HQSplit' - -- other - | SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query - | FindShallowI Path' - | FindPatchI - | ShowDefinitionI OutputLocation [HQ.HashQualified Name] - | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] - | ShowReflogI - | UpdateBuiltinsI - | MergeBuiltinsI - | MergeIOBuiltinsI - | ListDependenciesI (HQ.HashQualified Name) - | ListDependentsI (HQ.HashQualified Name) - | DebugNumberedArgsI - | DebugTypecheckedUnisonFileI - | DebugDumpNamespacesI - | DebugDumpNamespaceSimpleI - | DebugClearWatchI - | QuitI - | UiI - deriving (Eq, Show) -- <<< RLM: Need to figure this one out - --- Some commands, like `view`, can dump output to either console or a file. -data OutputLocation - = ConsoleLocation - | LatestFileLocation - | FileLocation FilePath - -- ClipboardLocation - deriving (Eq, Show) - --- OUTPUT STUFF BELOW -type ListDetailed = Bool -type NumberedArgs = [String] - -data PushPull = Push | Pull deriving (Eq, Ord, Show) - -pushPull :: a -> a -> PushPull -> a -pushPull push pull p = case p of - Push -> push - Pull -> pull - -data NumberedOutput v - = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - -- - | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) - --- | ShowDiff - --- RLM: SPIKE - Ok a creative but potentially bad idea that would solve many of my woes is to break out Output v into OutputWithNoType Parameter. -data OutputSimple - = PrintMessage (P.Pretty P.ColorText) - | Success - deriving (Eq, Show) - -data Output v - -- Generic Success response; we might consider deleting this. - = Simple OutputSimple -- RLM: Test here - -- User did `add` or `update` before typechecking a file? - | NoUnisonFile - | InvalidSourceName String - | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' - | CreatedNewBranch Path.Absolute - | BranchAlreadyExists Path' - | PatchAlreadyExists Path.Split' - | NoExactTypeMatches - | TypeAlreadyExists Path.Split' (Set Reference) - | TypeParseError String (Parser.Err v) - | ParseResolutionFailures String [Names.ResolutionFailure v Ann] - | TypeHasFreeVars (Type v Ann) - | TermAlreadyExists Path.Split' (Set Referent) - | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) - | LabeledReferenceNotFound (HQ.HashQualified Name) - | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) - | TermAmbiguous (HQ.HashQualified Name) (Set Referent) - | HashAmbiguous ShortHash (Set Referent) - | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) - | BranchNotFound Path' - | NameNotFound Path.HQSplit' - | PatchNotFound Path.Split' - | TypeNotFound Path.HQSplit' - | TermNotFound Path.HQSplit' - | TypeNotFound' ShortHash - | TermNotFound' ShortHash - | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) - | 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 - -- the path is deleted. - | DeleteBranchConfirmation - [(Path', (Names, [SearchResult' v Ann]))] - -- CantDelete input couldntDelete becauseTheseStillReferenceThem - | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] - | DeleteEverythingConfirmation - | DeletedEverything - | ListNames Int -- hq length to print References - [(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 Name, Reference, Maybe (Type v Ann))] - | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] - | ListOfPatches (Set Name) - -- show the result of add/update - | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) - -- Original source, followed by the errors: - | ParseErrors Text [Parser.Err v] - | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] - | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] - | DisplayConflicts (Relation Name Referent) (Relation Name Reference) - | EvaluationFailure Runtime.Error - | Evaluated SourceFileContents - PPE.PrettyPrintEnv - [(v, Term v ())] - (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) - | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) - | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) - -- "display" definitions, possibly to a FilePath on disk (e.g. editing) - | DisplayDefinitions (Maybe FilePath) - PPE.PrettyPrintEnvDecl - (Map Reference (DisplayObject () (Decl v Ann))) - (Map Reference (DisplayObject (Type v Ann) (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) - | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) - | TestResults TestReportStats - PPE.PrettyPrintEnv ShowSuccesses ShowFailures - [(Reference, Text)] -- oks - [(Reference, Text)] -- fails - | CantUndo UndoFailureReason - | ListEdits Patch PPE.PrettyPrintEnv - - -- new/unrepresented references followed by old/removed - -- todo: eventually replace these sets with [SearchResult' v Ann] - -- and a nicer render. - | BustedBuiltins (Set Reference) (Set Reference) - | GitError Input GitError - | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) - | NoConfiguredGitUrl PushPull Path' - | ConfiguredGitUrlParseError PushPull Path' Text String - | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata - (Map Reference (DisplayObject () (Decl v Ann))) - (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) - | MetadataMissingType 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 - | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) - | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) - | StartOfCurrentPathHistory - | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail - | ShowReflog [ReflogEntry] - | PullAlreadyUpToDate ReadRemoteNamespace Path' - | MergeAlreadyUpToDate Path' Path' - | PreviewMergeAlreadyUpToDate Path' Path' - -- | No conflicts or edits remain for the current patch. - | NoConflictsOrEdits - | NotImplemented - | NoBranchWithHash ShortBranchHash - | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) - | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) - | DumpNumberedArgs NumberedArgs - | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) - | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] - | BadName String - | DefaultMetadataNotification - | BadRootBranch GetRootBranchError - | CouldntLoadBranch Branch.Hash - | NoOp - deriving (Show) - -data ReflogEntry = - ReflogEntry { hash :: ShortBranchHash, reason :: Text } - deriving (Show) - -data HistoryTail = - EndOfLog ShortBranchHash | - MergeTail ShortBranchHash [ShortBranchHash] | - PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex - deriving (Show) - -data TestReportStats - = CachedTests TotalCount CachedCount - | NewlyComputed deriving Show - -type TotalCount = Int -- total number of tests -type CachedCount = Int -- number of tests found in the cache -type ShowSuccesses = Bool -- whether to list results or just summarize -type ShowFailures = Bool -- whether to list results or just summarize - -data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show - -type SourceFileContents = Text - -isFailure :: Ord v => Output v -> Bool -isFailure o = case o of - Simple Success{} -> False - Simple Onboarding{} -> False - BadRootBranch{} -> True - CouldntLoadBranch{} -> True - NoUnisonFile{} -> True - InvalidSourceName{} -> True - SourceLoadFailed{} -> True - NoMainFunction{} -> True - BadMainFunction{} -> True - CreatedNewBranch{} -> False - BranchAlreadyExists{} -> True - PatchAlreadyExists{} -> True - NoExactTypeMatches -> True - BranchEmpty{} -> True - BranchNotEmpty{} -> True - TypeAlreadyExists{} -> True - TypeParseError{} -> True - ParseResolutionFailures{} -> True - TypeHasFreeVars{} -> True - TermAlreadyExists{} -> True - LabeledReferenceAmbiguous{} -> True - LabeledReferenceNotFound{} -> True - DeleteNameAmbiguous{} -> True - TermAmbiguous{} -> True - BranchHashAmbiguous{} -> True - BadName{} -> True - BranchNotFound{} -> True - NameNotFound{} -> True - PatchNotFound{} -> True - TypeNotFound{} -> True - TypeNotFound'{} -> True - TermNotFound{} -> True - TermNotFound'{} -> True - TypeTermMismatch{} -> True - SearchTermsNotFound ts -> not (null ts) - DeleteBranchConfirmation{} -> False - CantDelete{} -> True - DeleteEverythingConfirmation -> False - DeletedEverything -> False - ListNames _ tys tms -> null tms && null tys - ListOfLinks _ ds -> null ds - ListOfDefinitions _ _ ds -> null ds - ListOfPatches s -> Set.null s - SlurpOutput _ _ sr -> not $ SR.isOk sr - ParseErrors{} -> True - TypeErrors{} -> True - CompilerBugs{} -> True - DisplayConflicts{} -> False - EvaluationFailure{} -> True - Evaluated{} -> False - Typechecked{} -> False - DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 - DisplayRendered{} -> False - TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) - TestIncrementalOutputStart{} -> False - TestIncrementalOutputEnd{} -> False - TestResults _ _ _ _ _ fails -> not (null fails) - CantUndo{} -> True - ListEdits{} -> False - GitError{} -> True - BustedBuiltins{} -> True - ConfiguredMetadataParseError{} -> True - NoConfiguredGitUrl{} -> True - ConfiguredGitUrlParseError{} -> True - DisplayLinks{} -> False - MetadataMissingType{} -> True - MetadataAmbiguous{} -> True - PatchNeedsToBeConflictFree{} -> True - PatchInvolvesExternalDependents{} -> True - NothingToPatch{} -> False - WarnIncomingRootBranch{} -> False - History{} -> False - StartOfCurrentPathHistory -> True - NotImplemented -> True - DumpNumberedArgs{} -> False - DumpBitBooster{} -> False - NoBranchWithHash{} -> True - PullAlreadyUpToDate{} -> False - MergeAlreadyUpToDate{} -> False - PreviewMergeAlreadyUpToDate{} -> False - NoConflictsOrEdits{} -> False - ListShallow _ es -> null es - HashAmbiguous{} -> True - ShowReflog{} -> False - LoadPullRequest{} -> False - DefaultMetadataNotification -> False - NoOp -> False - ListDependencies{} -> False - ListDependents{} -> False - TermMissingType{} -> True - DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty - -isNumberedFailure :: NumberedOutput v -> Bool -isNumberedFailure = \case - ShowDiffNamespace{} -> False - ShowDiffAfterDeleteDefinitions{} -> False - ShowDiffAfterDeleteBranch{} -> False - ShowDiffAfterModifyBranch{} -> False - ShowDiffAfterMerge{} -> False - ShowDiffAfterMergePropagate{} -> False - ShowDiffAfterMergePreview{} -> False - ShowDiffAfterUndo{} -> False - ShowDiffAfterPull{} -> False - ShowDiffAfterCreatePR{} -> False - ShowDiffAfterCreateAuthor{} -> False - - diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index 3641e54ce2..1cadaaf852 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -1,351 +1,350 @@ {-# LANGUAGE PatternSynonyms #-} module Unison.Codebase.Editor.Output - -- ( Output(..) - -- , NumberedOutput(..) - -- , NumberedArgs - -- , ListDetailed - -- , HistoryTail(..) - -- , TestReportStats(..) - -- , UndoFailureReason(..) - -- , PushPull(..) - -- , ReflogEntry(..) - -- , pushPull - -- , isFailure - -- , isNumberedFailure) -where + ( Output(..) + , NumberedOutput(..) + , NumberedArgs + , ListDetailed + , HistoryTail(..) + , TestReportStats(..) + , UndoFailureReason(..) + , PushPull(..) + , ReflogEntry(..) + , pushPull + , isFailure + , isNumberedFailure + ) where --- import Unison.Prelude +import Unison.Prelude --- import Unison.Server.Backend (ShallowListEntry(..)) --- -- import Unison.Codebase.Editor.InputOutput --- import Unison.Codebase.Editor.Input --- import Unison.Codebase (GetRootBranchError) --- import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) --- import Unison.Codebase.Path (Path') --- import Unison.Codebase.Patch (Patch) --- import Unison.Codebase.Type (GitError) --- import Unison.Name ( Name ) --- import Unison.Names2 ( Names ) --- import Unison.Parser.Ann (Ann) --- import qualified Unison.Reference as Reference --- import Unison.Reference ( Reference ) --- import Unison.Referent ( Referent ) --- import Unison.DataDeclaration ( Decl ) --- import Unison.Util.Relation (Relation) --- import qualified Unison.Codebase.Branch as Branch --- import qualified Unison.Codebase.Editor.SlurpResult as SR --- import qualified Unison.Codebase.Metadata as Metadata --- import qualified Unison.Codebase.Path as Path --- import qualified Unison.Codebase.Runtime as Runtime --- import qualified Unison.HashQualified as HQ --- import qualified Unison.HashQualified' as HQ' --- import qualified Unison.Parser as Parser --- import qualified Unison.PrettyPrintEnv as PPE --- import qualified Unison.PrettyPrintEnvDecl as PPE --- import qualified Unison.Typechecker.Context as Context --- import qualified Unison.UnisonFile as UF --- import qualified Unison.Util.Pretty as P --- import Unison.Codebase.Editor.DisplayObject (DisplayObject) --- import qualified Unison.Codebase.Editor.TodoOutput as TO --- import Unison.Server.SearchResult' (SearchResult') --- import Unison.Term (Term) --- import Unison.Type (Type) --- import qualified Unison.Names.ResolutionResult as Names --- import qualified Unison.Names3 as Names --- import qualified Data.Set as Set --- import Unison.NameSegment (NameSegment) --- import Unison.ShortHash (ShortHash) --- import Unison.Codebase.ShortBranchHash (ShortBranchHash) --- import Unison.Codebase.Editor.RemoteRepo --- import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) --- import Unison.LabeledDependency (LabeledDependency) --- import qualified Unison.WatchKind as WK +import Unison.Server.Backend (ShallowListEntry(..)) +import Unison.Codebase.Editor.Input +import Unison.Codebase (GetRootBranchError) +import Unison.Codebase.Editor.SlurpResult (SlurpResult(..)) +import Unison.Codebase.Path (Path') +import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Type (GitError) +import Unison.Name ( Name ) +import Unison.Names2 ( Names ) +import Unison.Parser.Ann (Ann) +import qualified Unison.Reference as Reference +import Unison.Reference ( Reference ) +import Unison.Referent ( Referent ) +import Unison.DataDeclaration ( Decl ) +import Unison.Util.Relation (Relation) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Editor.SlurpResult as SR +import qualified Unison.Codebase.Metadata as Metadata +import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Runtime as Runtime +import qualified Unison.HashQualified as HQ +import qualified Unison.HashQualified' as HQ' +import qualified Unison.Parser as Parser +import qualified Unison.PrettyPrintEnv as PPE +import qualified Unison.PrettyPrintEnvDecl as PPE +import qualified Unison.Typechecker.Context as Context +import qualified Unison.UnisonFile as UF +import qualified Unison.Util.Pretty as P +import Unison.Codebase.Editor.DisplayObject (DisplayObject) +import qualified Unison.Codebase.Editor.TodoOutput as TO +import Unison.Server.SearchResult' (SearchResult') +import Unison.Term (Term) +import Unison.Type (Type) +import qualified Unison.Names.ResolutionResult as Names +import qualified Unison.Names3 as Names +import qualified Data.Set as Set +import Unison.NameSegment (NameSegment) +import Unison.ShortHash (ShortHash) +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.Editor.RemoteRepo +import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) +import Unison.LabeledDependency (LabeledDependency) +import qualified Unison.WatchKind as WK --- type ListDetailed = Bool --- type SourceName = Text --- type NumberedArgs = [String] +type ListDetailed = Bool +type SourceName = Text +type NumberedArgs = [String] --- data PushPull = Push | Pull deriving (Eq, Ord, Show) +data PushPull = Push | Pull deriving (Eq, Ord, Show) --- pushPull :: a -> a -> PushPull -> a --- pushPull push pull p = case p of --- Push -> push --- Pull -> pull +pushPull :: a -> a -> PushPull -> a +pushPull push pull p = case p of + Push -> push + Pull -> pull --- data NumberedOutput v --- = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- -- --- | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) +data NumberedOutput v + = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMerge Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann) + -- + | ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann) --- -- | ShowDiff +-- | ShowDiff --- data Output v --- -- Generic Success response; we might consider deleting this. --- = Success --- | Onboarding String -- RLM Test - will eventually do more output --- -- User did `add` or `update` before typechecking a file? --- | NoUnisonFile --- | InvalidSourceName String --- | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' --- | CreatedNewBranch Path.Absolute --- | BranchAlreadyExists Path' --- | PatchAlreadyExists Path.Split' --- | NoExactTypeMatches --- | TypeAlreadyExists Path.Split' (Set Reference) --- | TypeParseError String (Parser.Err v) --- | ParseResolutionFailures String [Names.ResolutionFailure v Ann] --- | TypeHasFreeVars (Type v Ann) --- | TermAlreadyExists Path.Split' (Set Referent) --- | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) --- | LabeledReferenceNotFound (HQ.HashQualified Name) --- | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) --- | TermAmbiguous (HQ.HashQualified Name) (Set Referent) --- | HashAmbiguous ShortHash (Set Referent) --- | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) --- | BranchNotFound Path' --- | NameNotFound Path.HQSplit' --- | PatchNotFound Path.Split' --- | TypeNotFound Path.HQSplit' --- | TermNotFound Path.HQSplit' --- | TypeNotFound' ShortHash --- | TermNotFound' ShortHash --- | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) --- | 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 --- -- the path is deleted. --- | DeleteBranchConfirmation --- [(Path', (Names, [SearchResult' v Ann]))] --- -- CantDelete input couldntDelete becauseTheseStillReferenceThem --- | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] --- | DeleteEverythingConfirmation --- | DeletedEverything --- | ListNames Int -- hq length to print References --- [(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 Name, Reference, Maybe (Type v Ann))] --- | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] --- | ListOfPatches (Set Name) --- -- show the result of add/update --- | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) --- -- Original source, followed by the errors: --- | ParseErrors Text [Parser.Err v] --- | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] --- | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] --- | DisplayConflicts (Relation Name Referent) (Relation Name Reference) --- | EvaluationFailure Runtime.Error --- | Evaluated SourceFileContents --- PPE.PrettyPrintEnv --- [(v, Term v ())] --- (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) --- | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) --- | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) --- -- "display" definitions, possibly to a FilePath on disk (e.g. editing) --- | DisplayDefinitions (Maybe FilePath) --- PPE.PrettyPrintEnvDecl --- (Map Reference (DisplayObject () (Decl v Ann))) --- (Map Reference (DisplayObject (Type v Ann) (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) --- | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) --- | TestResults TestReportStats --- PPE.PrettyPrintEnv ShowSuccesses ShowFailures --- [(Reference, Text)] -- oks --- [(Reference, Text)] -- fails --- | CantUndo UndoFailureReason --- | ListEdits Patch PPE.PrettyPrintEnv +data Output v + -- Generic Success response; we might consider deleting this. + = Success + -- User did `add` or `update` before typechecking a file? + | NoUnisonFile + -- Used in Welcome module to instruct user + | PrintMessage (P.Pretty P.ColorText) + | InvalidSourceName String + | SourceLoadFailed String + -- No main function, the [Type v Ann] are the allowed types + | 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 ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' + | CreatedNewBranch Path.Absolute + | BranchAlreadyExists Path' + | PatchAlreadyExists Path.Split' + | NoExactTypeMatches + | TypeAlreadyExists Path.Split' (Set Reference) + | TypeParseError String (Parser.Err v) + | ParseResolutionFailures String [Names.ResolutionFailure v Ann] + | TypeHasFreeVars (Type v Ann) + | TermAlreadyExists Path.Split' (Set Referent) + | LabeledReferenceAmbiguous Int (HQ.HashQualified Name) (Set LabeledDependency) + | LabeledReferenceNotFound (HQ.HashQualified Name) + | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference) + | TermAmbiguous (HQ.HashQualified Name) (Set Referent) + | HashAmbiguous ShortHash (Set Referent) + | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) + | BranchNotFound Path' + | NameNotFound Path.HQSplit' + | PatchNotFound Path.Split' + | TypeNotFound Path.HQSplit' + | TermNotFound Path.HQSplit' + | TypeNotFound' ShortHash + | TermNotFound' ShortHash + | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) + | 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 + -- the path is deleted. + | DeleteBranchConfirmation + [(Path', (Names, [SearchResult' v Ann]))] + -- CantDelete input couldntDelete becauseTheseStillReferenceThem + | CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann] + | DeleteEverythingConfirmation + | DeletedEverything + | ListNames Int -- hq length to print References + [(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 Name, Reference, Maybe (Type v Ann))] + | ListShallow PPE.PrettyPrintEnv [ShallowListEntry v Ann] + | ListOfPatches (Set Name) + -- show the result of add/update + | SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) + -- Original source, followed by the errors: + | ParseErrors Text [Parser.Err v] + | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] + | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] + | DisplayConflicts (Relation Name Referent) (Relation Name Reference) + | EvaluationFailure Runtime.Error + | Evaluated SourceFileContents + PPE.PrettyPrintEnv + [(v, Term v ())] + (Map v (Ann, WK.WatchKind, Term v (), Runtime.IsCacheHit)) + | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult v) (UF.TypecheckedUnisonFile v Ann) + | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText) + -- "display" definitions, possibly to a FilePath on disk (e.g. editing) + | DisplayDefinitions (Maybe FilePath) + PPE.PrettyPrintEnvDecl + (Map Reference (DisplayObject () (Decl v Ann))) + (Map Reference (DisplayObject (Type v Ann) (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) + | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann) + | TestResults TestReportStats + PPE.PrettyPrintEnv ShowSuccesses ShowFailures + [(Reference, Text)] -- oks + [(Reference, Text)] -- fails + | CantUndo UndoFailureReason + | ListEdits Patch PPE.PrettyPrintEnv --- -- new/unrepresented references followed by old/removed --- -- todo: eventually replace these sets with [SearchResult' v Ann] --- -- and a nicer render. --- | BustedBuiltins (Set Reference) (Set Reference) --- | GitError GitErr --- | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) --- | NoConfiguredGitUrl PushPull Path' --- | ConfiguredGitUrlParseError PushPull Path' Text String --- | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata --- (Map Reference (DisplayObject () (Decl v Ann))) --- (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) --- | MetadataMissingType 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 --- | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) --- | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) --- | StartOfCurrentPathHistory --- | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail --- | ShowReflog [ReflogEntry] --- | PullAlreadyUpToDate ReadRemoteNamespace Path' --- | MergeAlreadyUpToDate Path' Path' --- | PreviewMergeAlreadyUpToDate Path' Path' --- -- | No conflicts or edits remain for the current patch. --- | NoConflictsOrEdits --- | NotImplemented --- | NoBranchWithHash ShortBranchHash --- | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) --- | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) --- | DumpNumberedArgs NumberedArgs --- | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) --- | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] --- | BadName String --- | DefaultMetadataNotification --- | BadRootBranch GetRootBranchError --- | CouldntLoadBranch Branch.Hash --- | NoOp --- deriving (Show) + -- new/unrepresented references followed by old/removed + -- todo: eventually replace these sets with [SearchResult' v Ann] + -- and a nicer render. + | BustedBuiltins (Set Reference) (Set Reference) + | GitError Input GitError + | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) + | NoConfiguredGitUrl PushPull Path' + | ConfiguredGitUrlParseError PushPull Path' Text String + | DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata + (Map Reference (DisplayObject () (Decl v Ann))) + (Map Reference (DisplayObject (Type v Ann) (Term v Ann))) + | MetadataMissingType 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 + | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) + | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash) + | StartOfCurrentPathHistory + | History (Maybe Int) [(ShortBranchHash, Names.Diff)] HistoryTail + | ShowReflog [ReflogEntry] + | PullAlreadyUpToDate ReadRemoteNamespace Path' + | MergeAlreadyUpToDate Path' Path' + | PreviewMergeAlreadyUpToDate Path' Path' + -- | No conflicts or edits remain for the current patch. + | NoConflictsOrEdits + | NotImplemented + | NoBranchWithHash ShortBranchHash + | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference) + | ListDependents Int LabeledDependency [(Name, Reference)] (Set Reference) + | DumpNumberedArgs NumberedArgs + | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) + | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] + | BadName String + | DefaultMetadataNotification + | BadRootBranch GetRootBranchError + | CouldntLoadBranch Branch.Hash + | NoOp + deriving (Show) --- data ReflogEntry = --- ReflogEntry { hash :: ShortBranchHash, reason :: Text } --- deriving (Show) +data ReflogEntry = + ReflogEntry { hash :: ShortBranchHash, reason :: Text } + deriving (Show) --- data HistoryTail = --- EndOfLog ShortBranchHash | --- MergeTail ShortBranchHash [ShortBranchHash] | --- PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex --- deriving (Show) +data HistoryTail = + EndOfLog ShortBranchHash | + MergeTail ShortBranchHash [ShortBranchHash] | + PageEnd ShortBranchHash Int -- PageEnd nextHash nextIndex + deriving (Show) --- data TestReportStats --- = CachedTests TotalCount CachedCount --- | NewlyComputed deriving Show +data TestReportStats + = CachedTests TotalCount CachedCount + | NewlyComputed deriving Show --- type TotalCount = Int -- total number of tests --- type CachedCount = Int -- number of tests found in the cache --- type ShowSuccesses = Bool -- whether to list results or just summarize --- type ShowFailures = Bool -- whether to list results or just summarize +type TotalCount = Int -- total number of tests +type CachedCount = Int -- number of tests found in the cache +type ShowSuccesses = Bool -- whether to list results or just summarize +type ShowFailures = Bool -- whether to list results or just summarize --- data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show +data UndoFailureReason = CantUndoPastStart | CantUndoPastMerge deriving Show --- type SourceFileContents = Text +type SourceFileContents = Text --- isFailure :: Ord v => Output v -> Bool --- isFailure o = case o of --- Success{} -> False --- Onboarding{} -> False --- BadRootBranch{} -> True --- CouldntLoadBranch{} -> True --- NoUnisonFile{} -> True --- InvalidSourceName{} -> True --- SourceLoadFailed{} -> True --- NoMainFunction{} -> True --- BadMainFunction{} -> True --- CreatedNewBranch{} -> False --- BranchAlreadyExists{} -> True --- PatchAlreadyExists{} -> True --- NoExactTypeMatches -> True --- BranchEmpty{} -> True --- BranchNotEmpty{} -> True --- TypeAlreadyExists{} -> True --- TypeParseError{} -> True --- ParseResolutionFailures{} -> True --- TypeHasFreeVars{} -> True --- TermAlreadyExists{} -> True --- LabeledReferenceAmbiguous{} -> True --- LabeledReferenceNotFound{} -> True --- DeleteNameAmbiguous{} -> True --- TermAmbiguous{} -> True --- BranchHashAmbiguous{} -> True --- BadName{} -> True --- BranchNotFound{} -> True --- NameNotFound{} -> True --- PatchNotFound{} -> True --- TypeNotFound{} -> True --- TypeNotFound'{} -> True --- TermNotFound{} -> True --- TermNotFound'{} -> True --- TypeTermMismatch{} -> True --- SearchTermsNotFound ts -> not (null ts) --- DeleteBranchConfirmation{} -> False --- CantDelete{} -> True --- DeleteEverythingConfirmation -> False --- DeletedEverything -> False --- ListNames _ tys tms -> null tms && null tys --- ListOfLinks _ ds -> null ds --- ListOfDefinitions _ _ ds -> null ds --- ListOfPatches s -> Set.null s --- SlurpOutput _ _ sr -> not $ SR.isOk sr --- ParseErrors{} -> True --- TypeErrors{} -> True --- CompilerBugs{} -> True --- DisplayConflicts{} -> False --- EvaluationFailure{} -> True --- Evaluated{} -> False --- Typechecked{} -> False --- DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 --- DisplayRendered{} -> False --- TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) --- TestIncrementalOutputStart{} -> False --- TestIncrementalOutputEnd{} -> False --- TestResults _ _ _ _ _ fails -> not (null fails) --- CantUndo{} -> True --- ListEdits{} -> False --- GitError{} -> True --- BustedBuiltins{} -> True --- ConfiguredMetadataParseError{} -> True --- NoConfiguredGitUrl{} -> True --- ConfiguredGitUrlParseError{} -> True --- DisplayLinks{} -> False --- MetadataMissingType{} -> True --- MetadataAmbiguous{} -> True --- PatchNeedsToBeConflictFree{} -> True --- PatchInvolvesExternalDependents{} -> True --- NothingToPatch{} -> False --- WarnIncomingRootBranch{} -> False --- History{} -> False --- StartOfCurrentPathHistory -> True --- NotImplemented -> True --- DumpNumberedArgs{} -> False --- DumpBitBooster{} -> False --- NoBranchWithHash{} -> True --- PullAlreadyUpToDate{} -> False --- MergeAlreadyUpToDate{} -> False --- PreviewMergeAlreadyUpToDate{} -> False --- NoConflictsOrEdits{} -> False --- ListShallow _ es -> null es --- HashAmbiguous{} -> True --- ShowReflog{} -> False --- LoadPullRequest{} -> False --- DefaultMetadataNotification -> False --- NoOp -> False --- ListDependencies{} -> False --- ListDependents{} -> False --- TermMissingType{} -> True --- DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty - --- isNumberedFailure :: NumberedOutput v -> Bool --- isNumberedFailure = \case --- ShowDiffNamespace{} -> False --- ShowDiffAfterDeleteDefinitions{} -> False --- ShowDiffAfterDeleteBranch{} -> False --- ShowDiffAfterModifyBranch{} -> False --- ShowDiffAfterMerge{} -> False --- ShowDiffAfterMergePropagate{} -> False --- ShowDiffAfterMergePreview{} -> False --- ShowDiffAfterUndo{} -> False --- ShowDiffAfterPull{} -> False --- ShowDiffAfterCreatePR{} -> False --- ShowDiffAfterCreateAuthor{} -> False +isFailure :: Ord v => Output v -> Bool +isFailure o = case o of + Success{} -> False + PrintMessage{} -> False + BadRootBranch{} -> True + CouldntLoadBranch{} -> True + NoUnisonFile{} -> True + InvalidSourceName{} -> True + SourceLoadFailed{} -> True + NoMainFunction{} -> True + BadMainFunction{} -> True + CreatedNewBranch{} -> False + BranchAlreadyExists{} -> True + PatchAlreadyExists{} -> True + NoExactTypeMatches -> True + BranchEmpty{} -> True + BranchNotEmpty{} -> True + TypeAlreadyExists{} -> True + TypeParseError{} -> True + ParseResolutionFailures{} -> True + TypeHasFreeVars{} -> True + TermAlreadyExists{} -> True + LabeledReferenceAmbiguous{} -> True + LabeledReferenceNotFound{} -> True + DeleteNameAmbiguous{} -> True + TermAmbiguous{} -> True + BranchHashAmbiguous{} -> True + BadName{} -> True + BranchNotFound{} -> True + NameNotFound{} -> True + PatchNotFound{} -> True + TypeNotFound{} -> True + TypeNotFound'{} -> True + TermNotFound{} -> True + TermNotFound'{} -> True + TypeTermMismatch{} -> True + SearchTermsNotFound ts -> not (null ts) + DeleteBranchConfirmation{} -> False + CantDelete{} -> True + DeleteEverythingConfirmation -> False + DeletedEverything -> False + ListNames _ tys tms -> null tms && null tys + ListOfLinks _ ds -> null ds + ListOfDefinitions _ _ ds -> null ds + ListOfPatches s -> Set.null s + SlurpOutput _ _ sr -> not $ SR.isOk sr + ParseErrors{} -> True + TypeErrors{} -> True + CompilerBugs{} -> True + DisplayConflicts{} -> False + EvaluationFailure{} -> True + Evaluated{} -> False + Typechecked{} -> False + DisplayDefinitions _ _ m1 m2 -> null m1 && null m2 + DisplayRendered{} -> False + TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo) + TestIncrementalOutputStart{} -> False + TestIncrementalOutputEnd{} -> False + TestResults _ _ _ _ _ fails -> not (null fails) + CantUndo{} -> True + ListEdits{} -> False + GitError{} -> True + BustedBuiltins{} -> True + ConfiguredMetadataParseError{} -> True + NoConfiguredGitUrl{} -> True + ConfiguredGitUrlParseError{} -> True + DisplayLinks{} -> False + MetadataMissingType{} -> True + MetadataAmbiguous{} -> True + PatchNeedsToBeConflictFree{} -> True + PatchInvolvesExternalDependents{} -> True + NothingToPatch{} -> False + WarnIncomingRootBranch{} -> False + History{} -> False + StartOfCurrentPathHistory -> True + NotImplemented -> True + DumpNumberedArgs{} -> False + DumpBitBooster{} -> False + NoBranchWithHash{} -> True + PullAlreadyUpToDate{} -> False + MergeAlreadyUpToDate{} -> False + PreviewMergeAlreadyUpToDate{} -> False + NoConflictsOrEdits{} -> False + ListShallow _ es -> null es + HashAmbiguous{} -> True + ShowReflog{} -> False + LoadPullRequest{} -> False + DefaultMetadataNotification -> False + NoOp -> False + ListDependencies{} -> False + ListDependents{} -> False + TermMissingType{} -> True + DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty +isNumberedFailure :: NumberedOutput v -> Bool +isNumberedFailure = \case + ShowDiffNamespace{} -> False + ShowDiffAfterDeleteDefinitions{} -> False + ShowDiffAfterDeleteBranch{} -> False + ShowDiffAfterModifyBranch{} -> False + ShowDiffAfterMerge{} -> False + ShowDiffAfterMergePropagate{} -> False + ShowDiffAfterMergePreview{} -> False + ShowDiffAfterUndo{} -> False + ShowDiffAfterPull{} -> False + ShowDiffAfterCreatePR{} -> False + ShowDiffAfterCreateAuthor{} -> False diff --git a/parser-typechecker/src/Unison/CommandLine.hs b/parser-typechecker/src/Unison/CommandLine.hs index e3773c4ad8..2d02ff37bd 100644 --- a/parser-typechecker/src/Unison/CommandLine.hs +++ b/parser-typechecker/src/Unison/CommandLine.hs @@ -27,7 +27,7 @@ import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Causal ( Causal ) import qualified Unison.Codebase.Causal as Causal -import Unison.Codebase.Editor.InputOutput (Event(..), Input(..)) +import Unison.Codebase.Editor.Input (Event(..), Input(..)) import qualified Unison.Server.SearchResult as SR import qualified Unison.Codebase.Watch as Watch import Unison.CommandLine.InputPattern (InputPattern (parse)) diff --git a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs index 4c6b77b9d4..18e94670d7 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs @@ -8,7 +8,7 @@ module Unison.CommandLine.InputPattern where import qualified System.Console.Haskeline as Line import Unison.Codebase (Codebase) import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Editor.InputOutput (Input (..)) +import Unison.Codebase.Editor.Input (Input (..)) import qualified Unison.Util.ColorText as CT import qualified Unison.Util.Pretty as P import Unison.Codebase.Path as Path diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index af0e1912e5..90c1cffe13 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -12,9 +12,9 @@ module Unison.CommandLine.OutputMessages where import Unison.Prelude hiding (unlessM) import qualified Unison.Codebase as Codebase -import Unison.Codebase.Editor.InputOutput -import qualified Unison.Codebase.Editor.InputOutput as E -import qualified Unison.Codebase.Editor.InputOutput as Output +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.Output.BranchDiff as OBD import qualified Unison.Server.SearchResult' as SR' @@ -118,7 +118,7 @@ import U.Codebase.Sqlite.DbId (SchemaVersion(SchemaVersion)) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError(UnrecognizedSchemaVersion, GitCouldntParseRootBranchHash)) import qualified Unison.Referent' as Referent import qualified Unison.WatchKind as WK -import qualified Unison.Codebase.Editor.InputOutput as Input +import qualified Unison.Codebase.Editor.Input as Input type Pretty = P.Pretty P.ColorText @@ -257,12 +257,9 @@ prettyRemoteNamespace = notifyUser :: forall v . Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of - -- Success -> pure $ P.bold "Done." - -- Onboarding string -> do - -- pure ( P.bold $ P.string ("HEY THIS IS ONBOARDING TEST responding to step: " ++ string)) - Simple Success -> pure $ P.bold "Done." - Simple (Onboarding string) -> do - pure ( P.bold $ P.string ("HEY THIS IS ONBOARDING TEST responding to step: " ++ string)) + Success -> pure $ P.bold "Done." + PrintMessage pretty -> do + pure pretty BadRootBranch e -> case e of Codebase.NoRootBranch -> pure . P.fatalCallout $ "I couldn't find the codebase root!" diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index ff880734a0..4a0993c5f0 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -12,7 +12,7 @@ import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode -import Unison.Codebase.Editor.InputOutput +import Unison.Codebase.Editor.Input import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) @@ -103,7 +103,7 @@ pullBase _ns = seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} - pullRemote = PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent + pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent in pure $ Right (pullRemote) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index c035580905..63a6a703c0 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -45,7 +45,6 @@ library Unison.Codebase.Editor.HandleCommand Unison.Codebase.Editor.HandleInput Unison.Codebase.Editor.Input - Unison.Codebase.Editor.InputOutput Unison.Codebase.Editor.Output Unison.Codebase.Editor.Output.BranchDiff Unison.Codebase.Editor.Output.DumpNamespace From 1ccf6ccdbeb6472de27b7f7eba6b65954d114139 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 28 Sep 2021 14:21:26 -0700 Subject: [PATCH 142/148] removes whitespace and notes --- .../src/Unison/Codebase/Editor/Command.hs | 4 - .../src/Unison/Codebase/Editor/HandleInput.hs | 7 +- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/CommandLine/InputPattern.hs | 9 -- .../src/Unison/CommandLine/Main.hs | 14 +- .../src/Unison/CommandLine/OutputMessages.hs | 1 - .../src/Unison/CommandLine/Welcome.hs | 137 +++++++----------- .../Unison/CommandLine/WelcomeInputQueue.hs | 134 ----------------- 8 files changed, 61 insertions(+), 247 deletions(-) delete mode 100644 parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs index e03ab12f82..dc3889a687 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs @@ -76,10 +76,6 @@ type TypecheckingResult v = Result (Seq (Note v Ann)) (Either Names0 (UF.TypecheckedUnisonFile v Ann)) --- m is the IO monad that you're interpreting into?? --- i is the type of the input. Input --- v is used for unison types and terms - the Var type --- a is the result of the command. So if it's a command that produces an Int, it's an Int. data Command m i v a where -- Escape hatch. Eval :: m a -> Command m i v a diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 91b8d49d91..bdf0c6cd4f 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -155,8 +155,6 @@ import qualified Unison.Codebase.Verbosity as Verbosity type F m i v = Free (Command m i v) -- type (Action m i v) a --- RLM Note: Action allows us to persist state and exit above what F will let you do. --- Persists state between commands. - the state that it persists is the LoopState type Action m i v = MaybeT (StateT (LoopState m v) (F m i v)) @@ -206,7 +204,6 @@ defaultPatchNameSegment = "patch" prettyPrintEnvDecl :: Names -> Action' m v PPE.PrettyPrintEnvDecl prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns) --- This returns an Action. loop :: forall m v . (Monad m, Var v) => Action m (Either Event Input) v () loop = do uf <- use latestTypecheckedFile @@ -338,7 +335,7 @@ loop = do else loadUnisonFile sourceName text Right input -> let - ifConfirmed = ifM (confirmedCommand input) -- RLM Note - maybe can copy this confirmed command state + ifConfirmed = ifM (confirmedCommand input) branchNotFound = respond . BranchNotFound branchNotFound' = respond . BranchNotFound . Path.unsplit' patchNotFound :: Path.Split' -> Action' m v () @@ -443,7 +440,7 @@ loop = do (uncurry3 printNamespace) orepo <> " " <> p' dest - CreateMessage{}-> wat + CreateMessage{} -> wat LoadI{} -> wat PreviewAddI{} -> wat PreviewUpdateI{} -> wat diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 58924d73fa..5211bf5881 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -62,7 +62,7 @@ data Input | ResetRootI (Either ShortBranchHash Path') -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? - -- CreateMessage is used in Welcome module to instruct user + -- used in Welcome module to give directions to user | CreateMessage (P.Pretty P.ColorText) -- change directory | SwitchBranchI Path' diff --git a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs index 18e94670d7..c1a55d6499 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPattern.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPattern.hs @@ -22,15 +22,6 @@ data IsOptional | OnePlus -- 1 or more, at the end deriving Show --- RLM note: Input pattern only triggers Input. --- but how can an input pattern be triggered. --- AI note: Haskeline takes keystrokes to [String] --- InputPattern takes [String] to Input --- HandleInput takes Input to Action (which is a monad that embeds Commands) --- - One of the Commands is to `Notify` the user of some `Output` --- HandleCommand takes individual `Command`s, does IO, and returns a result back to `HandleInput` --- OutputMessages turns `Output` into `Pretty` - data InputPattern = InputPattern { patternName :: String , aliases :: [String] diff --git a/parser-typechecker/src/Unison/CommandLine/Main.hs b/parser-typechecker/src/Unison/CommandLine/Main.hs index 2ade6deedf..2ad7d77963 100644 --- a/parser-typechecker/src/Unison/CommandLine/Main.hs +++ b/parser-typechecker/src/Unison/CommandLine/Main.hs @@ -121,7 +121,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba -- we watch for root branch tip changes, but want to ignore ones we expect. rootRef <- newIORef root pathRef <- newIORef initialPath - initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs -- Idea: Extract + initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs numberedArgsRef <- newIORef [] pageOutput <- newIORef True cancelFileSystemWatch <- watchFileSystem eventQueue dir @@ -156,11 +156,11 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba (putPrettyNonempty o) (putPrettyLnUnpaged o)) let - awaitInput = do -- await input ends up encompassing initial inputs (for welcome) and the user inputs + awaitInput = do -- use up buffered input before consulting external events - i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands welcome.downloadBase initialInputsRef -> initialInputsRef + i <- readIORef initialInputsRef (case i of - h:t -> writeIORef initialInputsRef t >> pure h -- Here was where we used to write the IO of commands to the event queue. Will need to mimic in an new function + h:t -> writeIORef initialInputsRef t >> pure h [] -> -- Race the user input and file watch. Async.race (atomically $ Q.peek eventQueue) getInput >>= \case @@ -168,7 +168,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let e = Left <$> atomically (Q.dequeue eventQueue) writeIORef pageOutput False e - x -> do -- x is Input + x -> do writeIORef pageOutput True pure x) `catch` interruptHandler interruptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput @@ -178,10 +178,10 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba cancelConfig cancelFileSystemWatch cancelWatchBranchUpdates - loop state = do -- I think this is the loop we should recreate or pull out. + loop state = do writeIORef pathRef (view HandleInput.currentPath state) let free = runStateT (runMaybeT HandleInput.loop) state - (o, state') <- HandleCommand.commandLine config awaitInput -- This is the actual call to the interpreter fo the commands- we can recycle it (we don't need to rewrite it) + (o, state') <- HandleCommand.commandLine config awaitInput (writeIORef rootRef) runtime notify diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index 90c1cffe13..5c015a680e 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -104,7 +104,6 @@ import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import Unison.Codebase.Editor.DisplayObject (DisplayObject(MissingObject, BuiltinObject, UserObject)) --- import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Hash as Hash import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 4a0993c5f0..894c096b1e 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -6,7 +6,6 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Prelude hiding (readFile, writeFile) import qualified Unison.Util.Pretty as P -import qualified Unison.PrettyTerminal as PT import System.Random (randomRIO) import Unison.Codebase.Path (Path) @@ -52,43 +51,18 @@ data Welcome = Welcome -- ONBOARDING data CodebaseInitStatus = NewlyCreatedCodebase FilePath -- Can transition to [Base, Author, Finished] - | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. RLM: TODO Show which codebase path was actually opened... + | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. data Onboarding - = Init CodebaseInitStatus -- Can transition to [Base, Author, Finished, PreviouslyOnboarded] - | Base BaseSteps -- Can transition to [Author, Finished] + = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] + | DownloadingBase ReadRemoteNamespace -- Can transition to [Author, Finished] | Author -- Can transition to [Finished] -- End States | Finished | PreviouslyOnboarded --- AI: Onboarding -> Action m v () - --- ucm start --- create codebase --- .... --- onboarding --- print out that we just created a codebase 56 steps earlier --- figureout if we need to download base ... Needed a codebase and base - --- ucm start --- codebase already exists --- .... --- onboarding --- figureout if we need to download base ... Needs base, but had an existing codebase - --- ucm start --- codebase exists --- .... --- onboarding --- this is my 100th time and i've got a codebase, and author and base -> PreviouslyOnboarded - -data BaseSteps - = DownloadingBase ReadRemoteNamespace - | DownloadBaseFailed ReadRemoteNamespace Text - | DownloadBaseSucceeded ReadRemoteNamespace - -data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase +data DownloadBase + = DownloadBase ReadRemoteNamespace | DontDownloadBase welcome :: DownloadBase -> Maybe FilePath -> FilePath -> String -> Welcome welcome downloadBase newCodebasePath watchDir unisonVersion = @@ -96,74 +70,57 @@ welcome downloadBase newCodebasePath watchDir unisonVersion = Just path -> Welcome (Init (NewlyCreatedCodebase path)) downloadBase newCodebasePath watchDir unisonVersion Nothing -> Welcome (Init PreviouslyCreatedCodebase) downloadBase newCodebasePath watchDir unisonVersion --- remove IO -pullBase :: ReadRemoteNamespace -> IO (Either Event Input) -pullBase _ns = - let +pullBase :: ReadRemoteNamespace -> Either Event Input +pullBase _ns = let seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent - in - pure $ Right (pullRemote) + in Right pullRemote run :: Codebase IO v a -> Welcome -> IO [Either Event Input] run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do go onboarding [] where - go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] -- try - -- consider: go :: Onboarding -> Action IO v () + go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] go onboarding acc = case onboarding of - Init (NewlyCreatedCodebase path) -> do - PT.putPrettyLn (header version) - PT.putPrettyLn (createdCodebase path) - determineFirstStep >>= \step -> go step acc - Init PreviouslyCreatedCodebase -> do - PT.putPrettyLn (header version) - determineFirstStep >>= \step -> go step acc - Base (DownloadingBase ns@(_, _, path)) -> do - PT.putPrettyLn $ downloading path - res <- pullBase ns - case res of - Right _ -> - go baseStep (res : acc) - where - baseStep = Base (DownloadBaseSucceeded ns) - Left _ -> -- event but baseDownload isn't an event so maybe change that type also this is probably a state we can't represent if we use the existing architecture - go baseError acc - where - baseError = Base (DownloadBaseFailed ns "Failed to download base") - Base (DownloadBaseSucceeded _) -> do - PT.putPrettyLn $ P.lines [ - P.wrap "✅ Success! The base library is the Unison standard library that includes", - P.wrap "core types and functions to write Unison code." - ] - -- getStarted dir >>= PT.putPrettyLn - - go Author acc - Base (DownloadBaseFailed _ _) -> do - PT.putPrettyLn "Download Failed" - getStarted dir >>= PT.putPrettyLn - pure acc - Author -> do - PT.putPrettyLn "Enter your author!" - go Finished acc + Init (NewlyCreatedCodebase path) -> do + determineFirstStep downloadBase codebase >>= \step -> go step ([toInput (createdCodebase path), toInput (header version)] ++ acc) + Init PreviouslyCreatedCodebase -> do + determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) + where + headerMsg = toInput (header version) + DownloadingBase ns@(_, _, path) -> + let + downloadMsg = Right $ CreateMessage (downloading path) + pullBaseInput = pullBase ns + in + go Author ([pullBaseInput, downloadMsg] ++ acc) + Author -> + let + authorMsg = toInput authorSuggestion + in go Finished (authorMsg : acc) + -- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards Finished -> do - getStarted dir >>= PT.putPrettyLn - pure acc + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) PreviouslyOnboarded -> do - getStarted dir >>= PT.putPrettyLn - pure acc - - determineFirstStep :: IO Onboarding - determineFirstStep = do - isBlankCodebase <- Codebase.isBlank codebase - case downloadBase of - DownloadBase ns | isBlankCodebase -> - pure $ Base (DownloadingBase ns) - _ -> - pure $ PreviouslyOnboarded + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) + +toInput :: P.Pretty P.ColorText -> Either Event Input +toInput pretty = + Right $ CreateMessage pretty + +determineFirstStep :: DownloadBase -> Codebase IO v a -> IO Onboarding +determineFirstStep downloadBase codebase = do + isBlankCodebase <- Codebase.isBlank codebase + case downloadBase of + DownloadBase ns | isBlankCodebase -> + pure $ DownloadingBase ns + _ -> + pure PreviouslyOnboarded asciiartUnison :: P.Pretty P.ColorText asciiartUnison = @@ -215,6 +172,14 @@ header version = P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline ] +authorSuggestion :: P.Pretty P.ColorText +authorSuggestion = + P.indentN 2 . P.wrap $ "🖌 You might want to set up your author next." + <> "Type" <> P.hiBlue "create.author" <> " to create an author for this codebase" + <> "Read about how to link your author to your code at " + <> P.blue "https://www.unisonweb.org/docs/configuration/#setting-default-metadata-like-license-and-author" + + createdCodebase :: FilePath -> P.Pretty P.ColorText createdCodebase dir = P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue (P.string dir) diff --git a/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs b/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs deleted file mode 100644 index 9b256e00cb..0000000000 --- a/parser-typechecker/src/Unison/CommandLine/WelcomeInputQueue.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.CommandLine.WelcomeInputQueue where - -import Unison.Prelude - -import Control.Concurrent.STM (atomically) --- import Control.Exception (finally, catch, AsyncException(UserInterrupt), asyncExceptionFromException) --- import Control.Monad.State (runStateT) --- import Data.Configurator.Types (Config) -import Data.IORef -import Prelude hiding (readFile, writeFile) --- import System.IO.Error (isDoesNotExistError) -import Unison.Codebase.Branch (Branch) --- import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Input (Input (..), Event) --- import qualified Unison.Server.CodebaseServer as Server --- import qualified Unison.Codebase.Editor.HandleInput as HandleInput --- import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand --- import Unison.Codebase.Editor.Command (LoadSourceResult(..)) -import Unison.Codebase (Codebase) -import Unison.CommandLine -import Unison.PrettyTerminal -import Unison.CommandLine.InputPattern (ArgumentType (suggestions), InputPattern (aliases, patternName)) -import Unison.CommandLine.InputPatterns (validInputs) --- import Unison.CommandLine.OutputMessages (notifyUser, notifyNumbered) -import Unison.Parser.Ann (Ann) -import Unison.Symbol (Symbol) -import qualified Control.Concurrent.Async as Async -import qualified Data.Map as Map -import qualified System.Console.Haskeline as Line -import qualified Unison.Codebase.Path as Path -import qualified Unison.CommandLine.InputPattern as IP -import qualified Unison.Util.Pretty as P -import qualified Unison.Util.TQueue as Q -import Text.Regex.TDFA - --- Expand a numeric argument like `1` or a range like `3-9` -expandNumber :: [String] -> String -> [String] -expandNumber numberedArgs s = - maybe [s] - (map (\i -> fromMaybe (show i) . atMay numberedArgs $ i - 1)) - expandedNumber - where - rangeRegex = "([0-9]+)-([0-9]+)" :: String - (junk,_,moreJunk, ns) = - s =~ rangeRegex :: (String, String, String, [String]) - expandedNumber = - case readMay s of - Just i -> Just [i] - Nothing -> - -- check for a range - case (junk, moreJunk, ns) of - ("", "", [from, to]) -> - (\x y -> [x..y]) <$> readMay from <*> readMay to - _ -> Nothing - -getInput :: IORef (Branch IO) -> IORef Path.Absolute -> IORef [String] -> Codebase IO v a -> IO Input -getInput rootRef pathRef numberedArgsRef codebase = do - root <- readIORef rootRef - path <- readIORef pathRef - numberedArgs <- readIORef numberedArgsRef - getUserInput patternMap codebase root path numberedArgs - where patternMap = Map.fromList $ validInputs >>= (\p -> (patternName p, p) : ((, p) <$> aliases p)) - -getUserInput - :: (MonadIO m, Line.MonadException m) - => Map String InputPattern - -> Codebase m v a - -> Branch m - -> Path.Absolute - -> [String] - -> m Input -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) - 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 - settings = Line.Settings tabComplete (Just ".unisonHistory") True - tabComplete = Line.completeWordWithPrev Nothing " " $ \prev word -> - -- User hasn't finished a command name, complete from command names - if null prev - then pure . exactComplete word $ Map.keys patterns - -- User has finished a command name; use completions for that command - else case words $ reverse prev of - h : t -> fromMaybe (pure []) $ do - p <- Map.lookup h patterns - argType <- IP.argType p (length t) - pure $ suggestions argType word codebase branch currentPath - _ -> pure [] - - -awaitInput :: - [Either Event Input] - -> Q.TQueue Event - -> IORef Bool - -> IORef (Branch IO) - -> IORef Path.Absolute - -> IORef [String] - -> Codebase IO Symbol Ann - -> IO (Either Event Input) -awaitInput initialInputs eventQueue pageOutput rootRef pathRef numberedArgsRef codebase = do -- await input ends up encompassing initial inputs (for welcome) and the user inputs - -- use up buffered input before consulting external events - initialInputsRef <- newIORef initialInputs - i <- readIORef initialInputsRef -- Here was where we used to do the reading for base commands - (case i of - h:t -> writeIORef initialInputsRef t >> pure h -- Here was where we used to write the IO of commands to the event queue. Will need to mimic in an new function - [] -> -- this means the initial inputs are done - -- Race the user input and file watch. - Async.race (atomically $ Q.peek eventQueue) (getInput rootRef pathRef numberedArgsRef codebase) >>= \case - Left _ -> do - let e = Left <$> atomically (Q.dequeue eventQueue) - writeIORef pageOutput False - e - x -> do - writeIORef pageOutput True - pure x) --`catch` interruptHandler - --interuptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput initialInputs eventQueue pageOutput rootRef pathRef numberedArgsRef codebase - --interruptHandler e = error (show e) - From 26575d97645753c078e213b029529a5ff437bcc7 Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 28 Sep 2021 16:06:38 -0700 Subject: [PATCH 143/148] tweaks language and welcome output --- .../Unison/Codebase/Editor/HandleCommand.hs | 5 +- .../src/Unison/CommandLine/Welcome.hs | 65 ++++++------------- .../unison-parser-typechecker.cabal | 1 - 3 files changed, 22 insertions(+), 49 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs index c2111a273c..44322edfb1 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs @@ -79,10 +79,10 @@ commandLine :: forall i v a gen . (Var v, Random.DRG gen) => Config - -> IO i -- RLM: await input + -> IO i -> (Branch IO -> IO ()) -> Runtime v - -> (Output v -> IO ()) -- RLM: notify + -> (Output v -> IO ()) -> (NumberedOutput v -> IO NumberedArgs) -> (SourceName -> IO LoadSourceResult) -> Codebase IO v Ann @@ -93,7 +93,6 @@ commandLine commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen = flip State.evalStateT 0 . Free.fold go where - -- RLM note : think of the return type of this as just the IO x 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 diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 894c096b1e..e59045809c 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -16,30 +16,8 @@ import Data.Sequence (singleton) import Unison.NameSegment (NameSegment(NameSegment)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) --- import qualified Unison.Codebase.Editor.Input as Input import qualified Unison.Codebase.Verbosity as Verbosity --- IDEAS? - --- Notes: --- Download base should be quieter - the printout is annoyingly large. --- use more primitive IO functions for user input and git download. --- UX issue / design constraint: if we use existing input / output architecture, how will we constrain the user into only entering their authorship info? --- we don't want the user to have too much "freedom" when entering their author info. --- Take a look at the transcript parser as an example of how to issue commands that is not in main --- Not sure about the empyt line to advance mechanic - how might we handle that with input/actions --- Another idea: - --- 1) --- * Refactor existing IO command loop out of main function - see notes in CommandLine.main --- * In Welcome.run; use existing interpreter to run commands --- * Implement a silencing mechanism - --- 2) --- * Run Codebase.importRemoteBranch directly in Welcome.runAction --- * Merge import result into .base - --- WELCOME data Welcome = Welcome { onboarding :: Onboarding -- Onboarding States , downloadBase :: DownloadBase @@ -48,7 +26,9 @@ data Welcome = Welcome , unisonVersion :: String } --- ONBOARDING +data DownloadBase + = DownloadBase ReadRemoteNamespace | DontDownloadBase + data CodebaseInitStatus = NewlyCreatedCodebase FilePath -- Can transition to [Base, Author, Finished] | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. @@ -61,9 +41,6 @@ data Onboarding | Finished | PreviouslyOnboarded -data DownloadBase - = DownloadBase ReadRemoteNamespace | DontDownloadBase - welcome :: DownloadBase -> Maybe FilePath -> FilePath -> String -> Welcome welcome downloadBase newCodebasePath watchDir unisonVersion = case newCodebasePath of @@ -85,22 +62,23 @@ run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, wat go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] go onboarding acc = case onboarding of - Init (NewlyCreatedCodebase path) -> do - determineFirstStep downloadBase codebase >>= \step -> go step ([toInput (createdCodebase path), toInput (header version)] ++ acc) + Init (NewlyCreatedCodebase _) -> do + determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) + where + headerMsg = toInput (header version) Init PreviouslyCreatedCodebase -> do determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) where headerMsg = toInput (header version) DownloadingBase ns@(_, _, path) -> - let + go Author ([pullBaseInput, downloadMsg] ++ acc) + where downloadMsg = Right $ CreateMessage (downloading path) pullBaseInput = pullBase ns - in - go Author ([pullBaseInput, downloadMsg] ++ acc) Author -> - let + go Finished (authorMsg : acc) + where authorMsg = toInput authorSuggestion - in go Finished (authorMsg : acc) -- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards Finished -> do startMsg <- getStarted dir @@ -150,8 +128,8 @@ asciiartUnison = downloading :: Path -> P.Pretty P.ColorText downloading path = - P.indentN 2 $ P.lines - [ P.newline <> P.newline, + P.lines + [ P.group (P.wrap "🐣 Since this is a fresh codebase, let me download the base library for you." <> P.newline ), P.wrap ("🕐 Downloading" <> P.blue (P.string (show path)) @@ -169,20 +147,17 @@ header version = <> P.newline <> P.linesSpaced [ P.wrap "👋 Welcome to Unison!", - P.wrap ("You are running version: " <> P.bold (P.string version)) <> P.newline + P.wrap ("You are running version: " <> P.bold (P.string version)) ] authorSuggestion :: P.Pretty P.ColorText authorSuggestion = - P.indentN 2 . P.wrap $ "🖌 You might want to set up your author next." - <> "Type" <> P.hiBlue "create.author" <> " to create an author for this codebase" - <> "Read about how to link your author to your code at " - <> P.blue "https://www.unisonweb.org/docs/configuration/#setting-default-metadata-like-license-and-author" - - -createdCodebase :: FilePath -> P.Pretty P.ColorText -createdCodebase dir = - P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue (P.string dir) + P.newline <> + P.lines [ P.wrap "📜 🪶 You might want to set up your author information next.", + P.wrap "Type" <> P.hiBlue " create.author" <> " to create an author for this codebase", + P.group( P.newline <> P.wrap "Read about how to link your author to your code at"), + P.wrap $ P.blue "https://www.unisonweb.org/docs/configuration/#setting-default-metadata-like-license-and-author" + ] getStarted :: FilePath -> IO (P.Pretty P.ColorText) getStarted dir = do diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 63a6a703c0..66a3da4b33 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -91,7 +91,6 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome - Unison.CommandLine.WelcomeInputQueue Unison.DeclPrinter Unison.FileParser Unison.FileParsers From 6a9ba939d4b3368334a19a8fa0ada43f230c6d7d Mon Sep 17 00:00:00 2001 From: rlmark Date: Tue, 28 Sep 2021 16:10:09 -0700 Subject: [PATCH 144/148] removed todo --- parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs | 1 - parser-typechecker/src/Unison/Codebase/Editor/Input.hs | 1 - parser-typechecker/unison/Main.hs | 2 +- 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index bdf0c6cd4f..e89988906a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -155,7 +155,6 @@ import qualified Unison.Codebase.Verbosity as Verbosity type F m i v = Free (Command m i v) -- type (Action m i v) a - type Action m i v = MaybeT (StateT (LoopState m v) (F m i v)) data LoopState m v diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs index 5211bf5881..c808d672fb 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Input.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Input.hs @@ -1,4 +1,3 @@ - module Unison.Codebase.Editor.Input ( Input(..) , Event(..) diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 68074ed5bd..72daff758c 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -253,7 +253,7 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase = Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS _ -> Welcome.DontDownloadBase - welcome = Welcome.welcome downloadBase Nothing dir Version.gitDescribe -- TODO + welcome = Welcome.welcome downloadBase Nothing dir Version.gitDescribe in CommandLine.main dir From 70393f00f48883b353a3600635d2b7f0778c8802 Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 30 Sep 2021 12:27:59 -0700 Subject: [PATCH 145/148] corner case where user creates a codebase with the --no-base flag and then exits without adding anything, and then re-opens it. --- .../src/Unison/CommandLine/Welcome.hs | 67 +++++++++---------- parser-typechecker/unison/Main.hs | 38 ++++++----- 2 files changed, 54 insertions(+), 51 deletions(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index e59045809c..0daa3ebe24 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -21,16 +21,15 @@ import qualified Unison.Codebase.Verbosity as Verbosity data Welcome = Welcome { onboarding :: Onboarding -- Onboarding States , downloadBase :: DownloadBase - , newCodebasePath :: Maybe FilePath , watchDir :: FilePath , unisonVersion :: String } -data DownloadBase +data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase data CodebaseInitStatus - = NewlyCreatedCodebase FilePath -- Can transition to [Base, Author, Finished] + = NewlyCreatedCodebase -- Can transition to [Base, Author, Finished] | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. data Onboarding @@ -41,55 +40,53 @@ data Onboarding | Finished | PreviouslyOnboarded -welcome :: DownloadBase -> Maybe FilePath -> FilePath -> String -> Welcome -welcome downloadBase newCodebasePath watchDir unisonVersion = - case newCodebasePath of - Just path -> Welcome (Init (NewlyCreatedCodebase path)) downloadBase newCodebasePath watchDir unisonVersion - Nothing -> Welcome (Init PreviouslyCreatedCodebase) downloadBase newCodebasePath watchDir unisonVersion +welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> String -> Welcome +welcome initStatus downloadBase filePath unisonVersion = + Welcome (Init initStatus) downloadBase filePath unisonVersion pullBase :: ReadRemoteNamespace -> Either Event Input pullBase _ns = let seg = NameSegment "base" rootPath = Path.Path { Path.toSeq = singleton seg } abs = Path.Absolute {Path.unabsolute = rootPath} - pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent + pullRemote = PullRemoteBranchI (Just _ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete Verbosity.Silent in Right pullRemote run :: Codebase IO v a -> Welcome -> IO [Either Event Input] run codebase Welcome { onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version } = do go onboarding [] where - go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] + go :: Onboarding -> [Either Event Input] -> IO [Either Event Input] go onboarding acc = case onboarding of - Init (NewlyCreatedCodebase _) -> do - determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) - where - headerMsg = toInput (header version) - Init PreviouslyCreatedCodebase -> do + Init NewlyCreatedCodebase -> do determineFirstStep downloadBase codebase >>= \step -> go step (headerMsg : acc) - where + where + headerMsg = toInput (header version) + Init PreviouslyCreatedCodebase -> do + go PreviouslyOnboarded (headerMsg : acc) + where headerMsg = toInput (header version) - DownloadingBase ns@(_, _, path) -> - go Author ([pullBaseInput, downloadMsg] ++ acc) - where + DownloadingBase ns@(_, _, path) -> + go Author ([pullBaseInput, downloadMsg] ++ acc) + where downloadMsg = Right $ CreateMessage (downloading path) pullBaseInput = pullBase ns - Author -> - go Finished (authorMsg : acc) - where - authorMsg = toInput authorSuggestion + Author -> + go Finished (authorMsg : acc) + where + authorMsg = toInput authorSuggestion -- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards Finished -> do - startMsg <- getStarted dir - pure $ reverse (toInput startMsg : acc) + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) PreviouslyOnboarded -> do - startMsg <- getStarted dir - pure $ reverse (toInput startMsg : acc) + startMsg <- getStarted dir + pure $ reverse (toInput startMsg : acc) -toInput :: P.Pretty P.ColorText -> Either Event Input -toInput pretty = - Right $ CreateMessage pretty +toInput :: P.Pretty P.ColorText -> Either Event Input +toInput pretty = + Right $ CreateMessage pretty determineFirstStep :: DownloadBase -> Codebase IO v a -> IO Onboarding determineFirstStep downloadBase codebase = do @@ -150,12 +147,12 @@ header version = P.wrap ("You are running version: " <> P.bold (P.string version)) ] -authorSuggestion :: P.Pretty P.ColorText -authorSuggestion = +authorSuggestion :: P.Pretty P.ColorText +authorSuggestion = P.newline <> - P.lines [ P.wrap "📜 🪶 You might want to set up your author information next.", - P.wrap "Type" <> P.hiBlue " create.author" <> " to create an author for this codebase", - P.group( P.newline <> P.wrap "Read about how to link your author to your code at"), + P.lines [ P.wrap "📜 🪶 You might want to set up your author information next.", + P.wrap "Type" <> P.hiBlue " create.author" <> " to create an author for this codebase", + P.group( P.newline <> P.wrap "Read about how to link your author to your code at"), P.wrap $ P.blue "https://www.unisonweb.org/docs/configuration/#setting-default-metadata-like-license-and-author" ] diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 72daff758c..2577050f1a 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -58,6 +58,7 @@ import ArgParse parseCLIArgs ) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import Unison.CommandLine.Welcome (CodebaseInitStatus(..)) main :: IO () main = do @@ -91,7 +92,7 @@ main = do ]) Run (RunFromSymbol mainName) -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption + ((closeCodebase, theCodebase),_) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime execute theCodebase runtime mainName closeCodebase @@ -102,17 +103,17 @@ main = do case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption + ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing ShouldNotDownloadBase + launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes closeCodebase Run (RunFromPipe mainName) -> do e <- safeReadUtf8StdIn case e of Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input." Right contents -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption + ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption rt <- RTI.startRuntime let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch @@ -120,11 +121,12 @@ main = do [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI] Nothing ShouldNotDownloadBase + initRes closeCodebase Transcript shouldFork shouldSaveCodebase transcriptFiles -> runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles Launch isHeadless codebaseServerOpts downloadBase -> do - (closeCodebase, theCodebase) <- getCodebaseOrExit mCodePathOption + ((closeCodebase, theCodebase),initRes) <- getCodebaseOrExit mCodePathOption runtime <- RTI.startRuntime Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do case isHeadless of @@ -146,7 +148,7 @@ main = do takeMVar mvar WithCLI -> do PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." - launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase + launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes closeCodebase prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath @@ -187,7 +189,7 @@ runTranscripts' mcodepath transcriptDir args = do Right stanzas -> do configFilePath <- getConfigFilePath mcodepath -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. - (closeCodebase, theCodebase) <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) + ((closeCodebase, theCodebase),_) <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase closeCodebase let out = currentDir FP. @@ -246,14 +248,18 @@ launch -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl -> ShouldDownloadBase + -> InitResult IO Symbol Ann -> IO () -launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase = +launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initResult = let downloadBase = case defaultBaseLib of Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS _ -> Welcome.DontDownloadBase - - welcome = Welcome.welcome downloadBase Nothing dir Version.gitDescribe + isNewCodebase = case initResult of + CreatedCodebase{} -> NewlyCreatedCodebase + _ -> PreviouslyCreatedCodebase + + welcome = Welcome.welcome isNewCodebase downloadBase dir Version.gitDescribe in CommandLine.main dir @@ -285,8 +291,8 @@ getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseD defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe) - -getCodebaseOrExit :: Maybe CodebasePathOption -> IO (IO (), Codebase.Codebase IO Symbol Ann) +-- (Unison.Codebase.Init.FinalizerAndCodebase IO Symbol Ann, InitResult IO Symbol Ann) +getCodebaseOrExit :: Maybe CodebasePathOption -> IO ((IO (), Codebase.Codebase IO Symbol Ann), InitResult IO Symbol Ann) getCodebaseOrExit codebasePathOption = do initOptions <- argsToCodebaseInitOptions codebasePathOption CodebaseInit.openOrCreateCodebase SC.init "main" initOptions >>= \case @@ -316,14 +322,14 @@ getCodebaseOrExit codebasePathOption = do PT.putPrettyLn' msg Exit.exitFailure - CreatedCodebase dir cb -> do + c@(CreatedCodebase dir cb) -> do pDir <- prettyDir dir PT.putPrettyLn' "" PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue pDir - pure cb + pure (cb, c) -- rlm note - OpenedCodebase _ cb -> - pure cb + o@(OpenedCodebase _ cb) -> + pure (cb, o) where prettyDir dir = P.string <$> canonicalizePath dir From a34dfc765a8ce50428579bb047a1f6fb97b98b1c Mon Sep 17 00:00:00 2001 From: rlmark Date: Thu, 30 Sep 2021 12:37:16 -0700 Subject: [PATCH 146/148] cleans up notes --- parser-typechecker/src/Unison/CommandLine/Welcome.hs | 4 ++++ parser-typechecker/unison/Main.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/CommandLine/Welcome.hs b/parser-typechecker/src/Unison/CommandLine/Welcome.hs index 0daa3ebe24..ae67dce915 100644 --- a/parser-typechecker/src/Unison/CommandLine/Welcome.hs +++ b/parser-typechecker/src/Unison/CommandLine/Welcome.hs @@ -28,6 +28,10 @@ data Welcome = Welcome data DownloadBase = DownloadBase ReadRemoteNamespace | DontDownloadBase +-- Previously Created is different from Previously Onboarded because a user can +-- 1.) create a new codebase +-- 2.) decide not to go through the onboarding flow until later and exit +-- 3.) then reopen their blank codebase data CodebaseInitStatus = NewlyCreatedCodebase -- Can transition to [Base, Author, Finished] | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. diff --git a/parser-typechecker/unison/Main.hs b/parser-typechecker/unison/Main.hs index 2577050f1a..56b4bafda6 100644 --- a/parser-typechecker/unison/Main.hs +++ b/parser-typechecker/unison/Main.hs @@ -326,7 +326,7 @@ getCodebaseOrExit codebasePathOption = do pDir <- prettyDir dir PT.putPrettyLn' "" PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue pDir - pure (cb, c) -- rlm note + pure (cb, c) o@(OpenedCodebase _ cb) -> pure (cb, o) From 1e59d60cec9312dd6eeae05f59b78d0d109015a2 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 4 Oct 2021 08:32:30 -0500 Subject: [PATCH 147/148] Update release-steps.md --- docs/release-steps.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/docs/release-steps.md b/docs/release-steps.md index 4e8b1f111e..cfb205661f 100644 --- a/docs/release-steps.md +++ b/docs/release-steps.md @@ -63,13 +63,17 @@ __7__ Merge and promote to production any PRs pending [on the docs site](https://github.com/unisonweb/unisonweb-org/pulls) which are associated with the new release. Confirm with @rlmark. -__8__ +__8__ + +Bug @pchiusano to update [the Slack post](https://unisonlanguage.slack.com/files/TLL09QC85/FMT7TDDDY?origin_team=TLL09QC85) which provides install instructions for people coming from [the quickstart guide](https://www.unisonweb.org/docs/quickstart/). + +__9__ Announce on #contrib Slack channel. Template below. --- -Release announcement template - +Release announcement template (be sure to update the release urls) - We've just released a new version of Unison, $RELEASE_NAME, release notes here (link to the issue). Install/upgrade instructions in the thread. From 507fc0957e9c35e1c78d4a72b42f1e2bc784308a Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 4 Oct 2021 13:28:55 -0500 Subject: [PATCH 148/148] refresh transcripts --- unison-src/transcripts/alias-many.output.md | 736 +++++++++--------- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 5 files changed, 393 insertions(+), 389 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 337271f7a3..30f60cd2d2 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -47,420 +47,424 @@ Let's try it! 27. Bytes.fromBase64 : Bytes -> Either Text Bytes 28. Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes 29. Bytes.fromList : [Nat] -> Bytes - 30. Bytes.size : Bytes -> Nat - 31. Bytes.take : Nat -> Bytes -> Bytes - 32. Bytes.toBase16 : Bytes -> Bytes - 33. Bytes.toBase32 : Bytes -> Bytes - 34. Bytes.toBase64 : Bytes -> Bytes - 35. Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 36. Bytes.toList : Bytes -> [Nat] - 37. builtin type Char - 38. Char.fromNat : Nat -> Char - 39. Char.toNat : Char -> Nat - 40. Char.toText : Char -> Text - 41. builtin type Code - 42. Code.cache_ : [(Term, Code)] ->{IO} [Term] - 43. Code.dependencies : Code -> [Term] - 44. Code.deserialize : Bytes -> Either Text Code - 45. Code.display : Text -> Code -> Text - 46. Code.isMissing : Term ->{IO} Boolean - 47. Code.lookup : Term ->{IO} Optional Code - 48. Code.serialize : Code -> Bytes - 49. Code.validate : [(Term, Code)] ->{IO} Optional Failure - 50. crypto.hash : HashAlgorithm -> a -> Bytes - 51. builtin type crypto.HashAlgorithm - 52. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 53. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 54. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 55. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 56. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 57. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 58. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 59. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 60. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 61. crypto.hmacBytes : HashAlgorithm + 30. Bytes.gzip.compress : Bytes -> Bytes + 31. Bytes.gzip.decompress : Bytes -> Either Text Bytes + 32. Bytes.size : Bytes -> Nat + 33. Bytes.take : Nat -> Bytes -> Bytes + 34. Bytes.toBase16 : Bytes -> Bytes + 35. Bytes.toBase32 : Bytes -> Bytes + 36. Bytes.toBase64 : Bytes -> Bytes + 37. Bytes.toBase64UrlUnpadded : Bytes -> Bytes + 38. Bytes.toList : Bytes -> [Nat] + 39. Bytes.zlib.compress : Bytes -> Bytes + 40. Bytes.zlib.decompress : Bytes -> Either Text Bytes + 41. builtin type Char + 42. Char.fromNat : Nat -> Char + 43. Char.toNat : Char -> Nat + 44. Char.toText : Char -> Text + 45. builtin type Code + 46. Code.cache_ : [(Term, Code)] ->{IO} [Term] + 47. Code.dependencies : Code -> [Term] + 48. Code.deserialize : Bytes -> Either Text Code + 49. Code.display : Text -> Code -> Text + 50. Code.isMissing : Term ->{IO} Boolean + 51. Code.lookup : Term ->{IO} Optional Code + 52. Code.serialize : Code -> Bytes + 53. Code.validate : [(Term, Code)] ->{IO} Optional Failure + 54. crypto.hash : HashAlgorithm -> a -> Bytes + 55. builtin type crypto.HashAlgorithm + 56. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 57. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 58. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 59. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 60. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 61. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 62. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 63. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 64. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 65. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 62. Debug.watch : Text -> a -> a - 63. unique type Doc - 64. Doc.Blob : Text -> Doc - 65. Doc.Evaluate : Term -> Doc - 66. Doc.Join : [Doc] -> Doc - 67. Doc.Link : Link -> Doc - 68. Doc.Signature : Term -> Doc - 69. Doc.Source : Link -> Doc - 70. structural type Either a b - 71. Either.Left : a -> Either a b - 72. Either.Right : b -> Either a b - 73. structural ability Exception - 74. Exception.raise : Failure ->{Exception} x - 75. builtin type Float - 76. Float.* : Float -> Float -> Float - 77. Float.+ : Float -> Float -> Float - 78. Float.- : Float -> Float -> Float - 79. Float./ : Float -> Float -> Float - 80. Float.abs : Float -> Float - 81. Float.acos : Float -> Float - 82. Float.acosh : Float -> Float - 83. Float.asin : Float -> Float - 84. Float.asinh : Float -> Float - 85. Float.atan : Float -> Float - 86. Float.atan2 : Float -> Float -> Float - 87. Float.atanh : Float -> Float - 88. Float.ceiling : Float -> Int - 89. Float.cos : Float -> Float - 90. Float.cosh : Float -> Float - 91. Float.eq : Float -> Float -> Boolean - 92. Float.exp : Float -> Float - 93. Float.floor : Float -> Int - 94. Float.fromRepresentation : Nat -> Float - 95. Float.fromText : Text -> Optional Float - 96. Float.gt : Float -> Float -> Boolean - 97. Float.gteq : Float -> Float -> Boolean - 98. Float.log : Float -> Float - 99. Float.logBase : Float -> Float -> Float - 100. Float.lt : Float -> Float -> Boolean - 101. Float.lteq : Float -> Float -> Boolean - 102. Float.max : Float -> Float -> Float - 103. Float.min : Float -> Float -> Float - 104. Float.pow : Float -> Float -> Float - 105. Float.round : Float -> Int - 106. Float.sin : Float -> Float - 107. Float.sinh : Float -> Float - 108. Float.sqrt : Float -> Float - 109. Float.tan : Float -> Float - 110. Float.tanh : Float -> Float - 111. Float.toRepresentation : Float -> Nat - 112. Float.toText : Float -> Text - 113. Float.truncate : Float -> Int - 114. builtin type Int - 115. Int.* : Int -> Int -> Int - 116. Int.+ : Int -> Int -> Int - 117. Int.- : Int -> Int -> Int - 118. Int./ : Int -> Int -> Int - 119. Int.and : Int -> Int -> Int - 120. Int.complement : Int -> Int - 121. Int.eq : Int -> Int -> Boolean - 122. Int.fromRepresentation : Nat -> Int - 123. Int.fromText : Text -> Optional Int - 124. Int.gt : Int -> Int -> Boolean - 125. Int.gteq : Int -> Int -> Boolean - 126. Int.increment : Int -> Int - 127. Int.isEven : Int -> Boolean - 128. Int.isOdd : Int -> Boolean - 129. Int.leadingZeros : Int -> Nat - 130. Int.lt : Int -> Int -> Boolean - 131. Int.lteq : Int -> Int -> Boolean - 132. Int.mod : Int -> Int -> Int - 133. Int.negate : Int -> Int - 134. Int.or : Int -> Int -> Int - 135. Int.popCount : Int -> Nat - 136. Int.pow : Int -> Nat -> Int - 137. Int.shiftLeft : Int -> Nat -> Int - 138. Int.shiftRight : Int -> Nat -> Int - 139. Int.signum : Int -> Int - 140. Int.toFloat : Int -> Float - 141. Int.toRepresentation : Int -> Nat - 142. Int.toText : Int -> Text - 143. Int.trailingZeros : Int -> Nat - 144. Int.truncate0 : Int -> Nat - 145. Int.xor : Int -> Int -> Int - 146. unique type io2.BufferMode - 147. io2.BufferMode.BlockBuffering : BufferMode - 148. io2.BufferMode.LineBuffering : BufferMode - 149. io2.BufferMode.NoBuffering : BufferMode - 150. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 151. unique type io2.Failure - 152. io2.Failure.Failure : Type -> Text -> Any -> Failure - 153. unique type io2.FileMode - 154. io2.FileMode.Append : FileMode - 155. io2.FileMode.Read : FileMode - 156. io2.FileMode.ReadWrite : FileMode - 157. io2.FileMode.Write : FileMode - 158. builtin type io2.Handle - 159. builtin type io2.IO - 160. io2.IO.clientSocket.impl : Text + 66. Debug.watch : Text -> a -> a + 67. unique type Doc + 68. Doc.Blob : Text -> Doc + 69. Doc.Evaluate : Term -> Doc + 70. Doc.Join : [Doc] -> Doc + 71. Doc.Link : Link -> Doc + 72. Doc.Signature : Term -> Doc + 73. Doc.Source : Link -> Doc + 74. structural type Either a b + 75. Either.Left : a -> Either a b + 76. Either.Right : b -> Either a b + 77. structural ability Exception + 78. Exception.raise : Failure ->{Exception} x + 79. builtin type Float + 80. Float.* : Float -> Float -> Float + 81. Float.+ : Float -> Float -> Float + 82. Float.- : Float -> Float -> Float + 83. Float./ : Float -> Float -> Float + 84. Float.abs : Float -> Float + 85. Float.acos : Float -> Float + 86. Float.acosh : Float -> Float + 87. Float.asin : Float -> Float + 88. Float.asinh : Float -> Float + 89. Float.atan : Float -> Float + 90. Float.atan2 : Float -> Float -> Float + 91. Float.atanh : Float -> Float + 92. Float.ceiling : Float -> Int + 93. Float.cos : Float -> Float + 94. Float.cosh : Float -> Float + 95. Float.eq : Float -> Float -> Boolean + 96. Float.exp : Float -> Float + 97. Float.floor : Float -> Int + 98. Float.fromRepresentation : Nat -> Float + 99. Float.fromText : Text -> Optional Float + 100. Float.gt : Float -> Float -> Boolean + 101. Float.gteq : Float -> Float -> Boolean + 102. Float.log : Float -> Float + 103. Float.logBase : Float -> Float -> Float + 104. Float.lt : Float -> Float -> Boolean + 105. Float.lteq : Float -> Float -> Boolean + 106. Float.max : Float -> Float -> Float + 107. Float.min : Float -> Float -> Float + 108. Float.pow : Float -> Float -> Float + 109. Float.round : Float -> Int + 110. Float.sin : Float -> Float + 111. Float.sinh : Float -> Float + 112. Float.sqrt : Float -> Float + 113. Float.tan : Float -> Float + 114. Float.tanh : Float -> Float + 115. Float.toRepresentation : Float -> Nat + 116. Float.toText : Float -> Text + 117. Float.truncate : Float -> Int + 118. builtin type Int + 119. Int.* : Int -> Int -> Int + 120. Int.+ : Int -> Int -> Int + 121. Int.- : Int -> Int -> Int + 122. Int./ : Int -> Int -> Int + 123. Int.and : Int -> Int -> Int + 124. Int.complement : Int -> Int + 125. Int.eq : Int -> Int -> Boolean + 126. Int.fromRepresentation : Nat -> Int + 127. Int.fromText : Text -> Optional Int + 128. Int.gt : Int -> Int -> Boolean + 129. Int.gteq : Int -> Int -> Boolean + 130. Int.increment : Int -> Int + 131. Int.isEven : Int -> Boolean + 132. Int.isOdd : Int -> Boolean + 133. Int.leadingZeros : Int -> Nat + 134. Int.lt : Int -> Int -> Boolean + 135. Int.lteq : Int -> Int -> Boolean + 136. Int.mod : Int -> Int -> Int + 137. Int.negate : Int -> Int + 138. Int.or : Int -> Int -> Int + 139. Int.popCount : Int -> Nat + 140. Int.pow : Int -> Nat -> Int + 141. Int.shiftLeft : Int -> Nat -> Int + 142. Int.shiftRight : Int -> Nat -> Int + 143. Int.signum : Int -> Int + 144. Int.toFloat : Int -> Float + 145. Int.toRepresentation : Int -> Nat + 146. Int.toText : Int -> Text + 147. Int.trailingZeros : Int -> Nat + 148. Int.truncate0 : Int -> Nat + 149. Int.xor : Int -> Int -> Int + 150. unique type io2.BufferMode + 151. io2.BufferMode.BlockBuffering : BufferMode + 152. io2.BufferMode.LineBuffering : BufferMode + 153. io2.BufferMode.NoBuffering : BufferMode + 154. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 155. unique type io2.Failure + 156. io2.Failure.Failure : Type -> Text -> Any -> Failure + 157. unique type io2.FileMode + 158. io2.FileMode.Append : FileMode + 159. io2.FileMode.Read : FileMode + 160. io2.FileMode.ReadWrite : FileMode + 161. io2.FileMode.Write : FileMode + 162. builtin type io2.Handle + 163. builtin type io2.IO + 164. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 161. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 162. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 163. io2.IO.createDirectory.impl : Text + 165. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 166. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 167. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 164. io2.IO.createTempDirectory.impl : Text + 168. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 165. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 166. io2.IO.directoryContents.impl : Text + 169. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 170. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 167. io2.IO.fileExists.impl : Text + 171. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 168. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 169. io2.IO.getBuffering.impl : Handle + 172. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 173. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 170. io2.IO.getBytes.impl : Handle + 174. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 171. io2.IO.getCurrentDirectory.impl : '{IO} Either + 175. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 172. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 173. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 174. io2.IO.getFileTimestamp.impl : Text + 176. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 177. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 178. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 175. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 176. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 177. io2.IO.handlePosition.impl : Handle + 179. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 180. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 181. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 178. io2.IO.isDirectory.impl : Text + 182. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 179. io2.IO.isFileEOF.impl : Handle + 183. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 180. io2.IO.isFileOpen.impl : Handle + 184. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 181. io2.IO.isSeekable.impl : Handle + 185. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 182. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 183. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 184. io2.IO.openFile.impl : Text + 186. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 187. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 188. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 185. io2.IO.putBytes.impl : Handle + 189. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 186. io2.IO.ref : a ->{IO} Ref {IO} a - 187. io2.IO.removeDirectory.impl : Text + 190. io2.IO.ref : a ->{IO} Ref {IO} a + 191. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 188. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 189. io2.IO.renameDirectory.impl : Text + 192. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 193. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 190. io2.IO.renameFile.impl : Text + 194. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 191. io2.IO.seekHandle.impl : Handle + 195. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 192. io2.IO.serverSocket.impl : Optional Text + 196. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 193. io2.IO.setBuffering.impl : Handle + 197. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 194. io2.IO.setCurrentDirectory.impl : Text + 198. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 195. io2.IO.socketAccept.impl : Socket + 199. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 196. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 197. io2.IO.socketReceive.impl : Socket + 200. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 201. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 198. io2.IO.socketSend.impl : Socket + 202. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 199. io2.IO.stdHandle : StdHandle -> Handle - 200. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 201. io2.IO.systemTimeMicroseconds : '{IO} Int - 202. unique type io2.IOError - 203. io2.IOError.AlreadyExists : IOError - 204. io2.IOError.EOF : IOError - 205. io2.IOError.IllegalOperation : IOError - 206. io2.IOError.NoSuchThing : IOError - 207. io2.IOError.PermissionDenied : IOError - 208. io2.IOError.ResourceBusy : IOError - 209. io2.IOError.ResourceExhausted : IOError - 210. io2.IOError.UserError : IOError - 211. unique type io2.IOFailure - 212. builtin type io2.MVar - 213. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 214. io2.MVar.new : a ->{IO} MVar a - 215. io2.MVar.newEmpty : '{IO} MVar a - 216. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 217. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 218. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 219. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 220. io2.MVar.tryPut.impl : MVar a + 203. io2.IO.stdHandle : StdHandle -> Handle + 204. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 205. io2.IO.systemTimeMicroseconds : '{IO} Int + 206. unique type io2.IOError + 207. io2.IOError.AlreadyExists : IOError + 208. io2.IOError.EOF : IOError + 209. io2.IOError.IllegalOperation : IOError + 210. io2.IOError.NoSuchThing : IOError + 211. io2.IOError.PermissionDenied : IOError + 212. io2.IOError.ResourceBusy : IOError + 213. io2.IOError.ResourceExhausted : IOError + 214. io2.IOError.UserError : IOError + 215. unique type io2.IOFailure + 216. builtin type io2.MVar + 217. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 218. io2.MVar.new : a ->{IO} MVar a + 219. io2.MVar.newEmpty : '{IO} MVar a + 220. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 221. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 222. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 223. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 224. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 221. io2.MVar.tryRead.impl : MVar a + 225. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 222. io2.MVar.tryTake : MVar a ->{IO} Optional a - 223. unique type io2.SeekMode - 224. io2.SeekMode.AbsoluteSeek : SeekMode - 225. io2.SeekMode.RelativeSeek : SeekMode - 226. io2.SeekMode.SeekFromEnd : SeekMode - 227. builtin type io2.Socket - 228. unique type io2.StdHandle - 229. io2.StdHandle.StdErr : StdHandle - 230. io2.StdHandle.StdIn : StdHandle - 231. io2.StdHandle.StdOut : StdHandle - 232. builtin type io2.STM - 233. io2.STM.atomically : '{STM} a ->{IO} a - 234. io2.STM.retry : '{STM} a - 235. builtin type io2.ThreadId - 236. builtin type io2.Tls - 237. builtin type io2.Tls.Cipher - 238. builtin type io2.Tls.ClientConfig - 239. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 226. io2.MVar.tryTake : MVar a ->{IO} Optional a + 227. unique type io2.SeekMode + 228. io2.SeekMode.AbsoluteSeek : SeekMode + 229. io2.SeekMode.RelativeSeek : SeekMode + 230. io2.SeekMode.SeekFromEnd : SeekMode + 231. builtin type io2.Socket + 232. unique type io2.StdHandle + 233. io2.StdHandle.StdErr : StdHandle + 234. io2.StdHandle.StdIn : StdHandle + 235. io2.StdHandle.StdOut : StdHandle + 236. builtin type io2.STM + 237. io2.STM.atomically : '{STM} a ->{IO} a + 238. io2.STM.retry : '{STM} a + 239. builtin type io2.ThreadId + 240. builtin type io2.Tls + 241. builtin type io2.Tls.Cipher + 242. builtin type io2.Tls.ClientConfig + 243. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 240. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 244. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 241. io2.Tls.ClientConfig.default : Text + 245. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 242. io2.Tls.ClientConfig.versions.set : [Version] + 246. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 243. io2.Tls.decodeCert.impl : Bytes + 247. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 244. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 245. io2.Tls.encodeCert : SignedCert -> Bytes - 246. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 247. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 248. io2.Tls.newClient.impl : ClientConfig + 248. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 249. io2.Tls.encodeCert : SignedCert -> Bytes + 250. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 251. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 252. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 249. io2.Tls.newServer.impl : ServerConfig + 253. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 250. builtin type io2.Tls.PrivateKey - 251. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 252. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 253. builtin type io2.Tls.ServerConfig - 254. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 254. builtin type io2.Tls.PrivateKey + 255. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 256. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 257. builtin type io2.Tls.ServerConfig + 258. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 255. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 259. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 256. io2.Tls.ServerConfig.default : [SignedCert] + 260. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 257. io2.Tls.ServerConfig.versions.set : [Version] + 261. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 258. builtin type io2.Tls.SignedCert - 259. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 260. builtin type io2.Tls.Version - 261. unique type io2.TlsFailure - 262. builtin type io2.TVar - 263. io2.TVar.new : a ->{STM} TVar a - 264. io2.TVar.newIO : a ->{IO} TVar a - 265. io2.TVar.read : TVar a ->{STM} a - 266. io2.TVar.readIO : TVar a ->{IO} a - 267. io2.TVar.swap : TVar a -> a ->{STM} a - 268. io2.TVar.write : TVar a -> a ->{STM} () - 269. unique type IsPropagated - 270. IsPropagated.IsPropagated : IsPropagated - 271. unique type IsTest - 272. IsTest.IsTest : IsTest - 273. unique type Link - 274. builtin type Link.Term - 275. Link.Term : Term -> Link - 276. Link.Term.toText : Term -> Text - 277. builtin type Link.Type - 278. Link.Type : Type -> Link - 279. builtin type List - 280. List.++ : [a] -> [a] -> [a] - 281. List.+: : a -> [a] -> [a] - 282. List.:+ : [a] -> a -> [a] - 283. List.at : Nat -> [a] -> Optional a - 284. List.cons : a -> [a] -> [a] - 285. List.drop : Nat -> [a] -> [a] - 286. List.empty : [a] - 287. List.size : [a] -> Nat - 288. List.snoc : [a] -> a -> [a] - 289. List.take : Nat -> [a] -> [a] - 290. metadata.isPropagated : IsPropagated - 291. metadata.isTest : IsTest - 292. builtin type Nat - 293. Nat.* : Nat -> Nat -> Nat - 294. Nat.+ : Nat -> Nat -> Nat - 295. Nat./ : Nat -> Nat -> Nat - 296. Nat.and : Nat -> Nat -> Nat - 297. Nat.complement : Nat -> Nat - 298. Nat.drop : Nat -> Nat -> Nat - 299. Nat.eq : Nat -> Nat -> Boolean - 300. Nat.fromText : Text -> Optional Nat - 301. Nat.gt : Nat -> Nat -> Boolean - 302. Nat.gteq : Nat -> Nat -> Boolean - 303. Nat.increment : Nat -> Nat - 304. Nat.isEven : Nat -> Boolean - 305. Nat.isOdd : Nat -> Boolean - 306. Nat.leadingZeros : Nat -> Nat - 307. Nat.lt : Nat -> Nat -> Boolean - 308. Nat.lteq : Nat -> Nat -> Boolean - 309. Nat.mod : Nat -> Nat -> Nat - 310. Nat.or : Nat -> Nat -> Nat - 311. Nat.popCount : Nat -> Nat - 312. Nat.pow : Nat -> Nat -> Nat - 313. Nat.shiftLeft : Nat -> Nat -> Nat - 314. Nat.shiftRight : Nat -> Nat -> Nat - 315. Nat.sub : Nat -> Nat -> Int - 316. Nat.toFloat : Nat -> Float - 317. Nat.toInt : Nat -> Int - 318. Nat.toText : Nat -> Text - 319. Nat.trailingZeros : Nat -> Nat - 320. Nat.xor : Nat -> Nat -> Nat - 321. structural type Optional a - 322. Optional.None : Optional a - 323. Optional.Some : a -> Optional a - 324. builtin type Ref - 325. Ref.read : Ref g a ->{g} a - 326. Ref.write : Ref g a -> a ->{g} () - 327. builtin type Request - 328. builtin type Scope - 329. Scope.ref : a ->{Scope s} Ref {Scope s} a - 330. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r - 331. structural type SeqView a b - 332. SeqView.VElem : a -> b -> SeqView a b - 333. SeqView.VEmpty : SeqView a b - 334. unique type Test.Result - 335. Test.Result.Fail : Text -> Result - 336. Test.Result.Ok : Text -> Result - 337. builtin type Text - 338. Text.!= : Text -> Text -> Boolean - 339. Text.++ : Text -> Text -> Text - 340. Text.drop : Nat -> Text -> Text - 341. Text.empty : Text - 342. Text.eq : Text -> Text -> Boolean - 343. Text.fromCharList : [Char] -> Text - 344. Text.fromUtf8.impl : Bytes -> Either Failure Text - 345. Text.gt : Text -> Text -> Boolean - 346. Text.gteq : Text -> Text -> Boolean - 347. Text.lt : Text -> Text -> Boolean - 348. Text.lteq : Text -> Text -> Boolean - 349. Text.repeat : Nat -> Text -> Text - 350. Text.size : Text -> Nat - 351. Text.take : Nat -> Text -> Text - 352. Text.toCharList : Text -> [Char] - 353. Text.toUtf8 : Text -> Bytes - 354. Text.uncons : Text -> Optional (Char, Text) - 355. Text.unsnoc : Text -> Optional (Text, Char) - 356. todo : a -> b - 357. structural type Tuple a b - 358. Tuple.Cons : a -> b -> Tuple a b - 359. structural type Unit - 360. Unit.Unit : () - 361. Universal.< : a -> a -> Boolean - 362. Universal.<= : a -> a -> Boolean - 363. Universal.== : a -> a -> Boolean - 364. Universal.> : a -> a -> Boolean - 365. Universal.>= : a -> a -> Boolean - 366. Universal.compare : a -> a -> Int - 367. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 368. builtin type Value - 369. Value.dependencies : Value -> [Term] - 370. Value.deserialize : Bytes -> Either Text Value - 371. Value.load : Value ->{IO} Either [Term] a - 372. Value.serialize : Value -> Bytes - 373. Value.value : a -> Value + 262. builtin type io2.Tls.SignedCert + 263. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 264. builtin type io2.Tls.Version + 265. unique type io2.TlsFailure + 266. builtin type io2.TVar + 267. io2.TVar.new : a ->{STM} TVar a + 268. io2.TVar.newIO : a ->{IO} TVar a + 269. io2.TVar.read : TVar a ->{STM} a + 270. io2.TVar.readIO : TVar a ->{IO} a + 271. io2.TVar.swap : TVar a -> a ->{STM} a + 272. io2.TVar.write : TVar a -> a ->{STM} () + 273. unique type IsPropagated + 274. IsPropagated.IsPropagated : IsPropagated + 275. unique type IsTest + 276. IsTest.IsTest : IsTest + 277. unique type Link + 278. builtin type Link.Term + 279. Link.Term : Term -> Link + 280. Link.Term.toText : Term -> Text + 281. builtin type Link.Type + 282. Link.Type : Type -> Link + 283. builtin type List + 284. List.++ : [a] -> [a] -> [a] + 285. List.+: : a -> [a] -> [a] + 286. List.:+ : [a] -> a -> [a] + 287. List.at : Nat -> [a] -> Optional a + 288. List.cons : a -> [a] -> [a] + 289. List.drop : Nat -> [a] -> [a] + 290. List.empty : [a] + 291. List.size : [a] -> Nat + 292. List.snoc : [a] -> a -> [a] + 293. List.take : Nat -> [a] -> [a] + 294. metadata.isPropagated : IsPropagated + 295. metadata.isTest : IsTest + 296. builtin type Nat + 297. Nat.* : Nat -> Nat -> Nat + 298. Nat.+ : Nat -> Nat -> Nat + 299. Nat./ : Nat -> Nat -> Nat + 300. Nat.and : Nat -> Nat -> Nat + 301. Nat.complement : Nat -> Nat + 302. Nat.drop : Nat -> Nat -> Nat + 303. Nat.eq : Nat -> Nat -> Boolean + 304. Nat.fromText : Text -> Optional Nat + 305. Nat.gt : Nat -> Nat -> Boolean + 306. Nat.gteq : Nat -> Nat -> Boolean + 307. Nat.increment : Nat -> Nat + 308. Nat.isEven : Nat -> Boolean + 309. Nat.isOdd : Nat -> Boolean + 310. Nat.leadingZeros : Nat -> Nat + 311. Nat.lt : Nat -> Nat -> Boolean + 312. Nat.lteq : Nat -> Nat -> Boolean + 313. Nat.mod : Nat -> Nat -> Nat + 314. Nat.or : Nat -> Nat -> Nat + 315. Nat.popCount : Nat -> Nat + 316. Nat.pow : Nat -> Nat -> Nat + 317. Nat.shiftLeft : Nat -> Nat -> Nat + 318. Nat.shiftRight : Nat -> Nat -> Nat + 319. Nat.sub : Nat -> Nat -> Int + 320. Nat.toFloat : Nat -> Float + 321. Nat.toInt : Nat -> Int + 322. Nat.toText : Nat -> Text + 323. Nat.trailingZeros : Nat -> Nat + 324. Nat.xor : Nat -> Nat -> Nat + 325. structural type Optional a + 326. Optional.None : Optional a + 327. Optional.Some : a -> Optional a + 328. builtin type Ref + 329. Ref.read : Ref g a ->{g} a + 330. Ref.write : Ref g a -> a ->{g} () + 331. builtin type Request + 332. builtin type Scope + 333. Scope.ref : a ->{Scope s} Ref {Scope s} a + 334. Scope.run : (∀ s. '{g, Scope s} r) ->{g} r + 335. structural type SeqView a b + 336. SeqView.VElem : a -> b -> SeqView a b + 337. SeqView.VEmpty : SeqView a b + 338. unique type Test.Result + 339. Test.Result.Fail : Text -> Result + 340. Test.Result.Ok : Text -> Result + 341. builtin type Text + 342. Text.!= : Text -> Text -> Boolean + 343. Text.++ : Text -> Text -> Text + 344. Text.drop : Nat -> Text -> Text + 345. Text.empty : Text + 346. Text.eq : Text -> Text -> Boolean + 347. Text.fromCharList : [Char] -> Text + 348. Text.fromUtf8.impl : Bytes -> Either Failure Text + 349. Text.gt : Text -> Text -> Boolean + 350. Text.gteq : Text -> Text -> Boolean + 351. Text.lt : Text -> Text -> Boolean + 352. Text.lteq : Text -> Text -> Boolean + 353. Text.repeat : Nat -> Text -> Text + 354. Text.size : Text -> Nat + 355. Text.take : Nat -> Text -> Text + 356. Text.toCharList : Text -> [Char] + 357. Text.toUtf8 : Text -> Bytes + 358. Text.uncons : Text -> Optional (Char, Text) + 359. Text.unsnoc : Text -> Optional (Text, Char) + 360. todo : a -> b + 361. structural type Tuple a b + 362. Tuple.Cons : a -> b -> Tuple a b + 363. structural type Unit + 364. Unit.Unit : () + 365. Universal.< : a -> a -> Boolean + 366. Universal.<= : a -> a -> Boolean + 367. Universal.== : a -> a -> Boolean + 368. Universal.> : a -> a -> Boolean + 369. Universal.>= : a -> a -> Boolean + 370. Universal.compare : a -> a -> Int + 371. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 372. builtin type Value + 373. Value.dependencies : Value -> [Term] + 374. Value.deserialize : Bytes -> Either Text Value + 375. Value.load : Value ->{IO} Either [Term] a + 376. Value.serialize : Value -> Bytes + 377. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -469,17 +473,17 @@ Let's try it! Added definitions: - 1. Float.fromRepresentation : Nat -> Float - 2. Float.fromText : Text -> Optional Float - 3. Float.gt : Float -> Float -> Boolean - 4. Float.gteq : Float -> Float -> Boolean - 5. Float.log : Float -> Float - 6. Float.logBase : Float -> Float -> Float - 7. Float.lt : Float -> Float -> Boolean - 8. Float.lteq : Float -> Float -> Boolean - 9. Float.max : Float -> Float -> Float - 10. Float.min : Float -> Float -> Float - 11. Float.pow : Float -> Float -> Float + 1. Float.cosh : Float -> Float + 2. Float.eq : Float -> Float -> Boolean + 3. Float.exp : Float -> Float + 4. Float.floor : Float -> Int + 5. Float.fromRepresentation : Nat -> Float + 6. Float.fromText : Text -> Optional Float + 7. Float.gt : Float -> Float -> Boolean + 8. Float.gteq : Float -> Float -> Boolean + 9. Float.log : Float -> Float + 10. Float.logBase : Float -> Float -> Float + 11. Float.lt : Float -> Float -> Boolean Tip: You can use `undo` or `reflog` to undo this change. @@ -539,17 +543,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.fromRepresentation : Nat -> Float - 2. Float.fromText : Text -> Optional Float - 3. Float.gt : Float -> Float -> Boolean - 4. Float.gteq : Float -> Float -> Boolean - 5. Float.log : Float -> Float - 6. Float.logBase : Float -> Float -> Float - 7. Float.lt : Float -> Float -> Boolean - 8. Float.lteq : Float -> Float -> Boolean - 9. Float.max : Float -> Float -> Float - 10. Float.min : Float -> Float -> Float - 11. Float.pow : Float -> Float -> Float + 1. Float.cosh : Float -> Float + 2. Float.eq : Float -> Float -> Boolean + 3. Float.exp : Float -> Float + 4. Float.floor : Float -> Int + 5. Float.fromRepresentation : Nat -> Float + 6. Float.fromText : Text -> Optional Float + 7. Float.gt : Float -> Float -> Boolean + 8. Float.gteq : Float -> Float -> Boolean + 9. Float.log : Float -> Float + 10. Float.logBase : Float -> Float -> Float + 11. Float.lt : Float -> Float -> Boolean 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 8ee89ca1cc..b286008b8d 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (373 definitions) + 1. builtin/ (377 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (541 definitions) + 1. builtin/ (545 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index d0e1e3b5ef..2492c0f190 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -112,13 +112,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - ⊙ #og6imo9b5c + ⊙ #ndukqgvtrb - Deletes: feature1.y - ⊙ #ejjdq2ngge + ⊙ #08c5fdtq6k + Adds / updates: @@ -129,26 +129,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - ⊙ #h52in37m2i + ⊙ #o17okbu7ug + Adds / updates: feature1.y - ⊙ #j82gbg1uvj + ⊙ #l37haj73av > Moves: Original name New name x master.x - ⊙ #avc2r4cma9 + ⊙ #1h0i8koq55 + Adds / updates: x - □ #4hqp1f8m4t (start of history) + □ #2t9dm55015 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 06ff0de76d..ffb2625466 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #u52c5mi247 .old` to make an old namespace + `fork #a0efcgu3if .old` to make an old namespace accessible again, - `reset-root #u52c5mi247` to reset the root namespace and + `reset-root #a0efcgu3if` to reset the root namespace and its history to that of the specified namespace. - 1. #67d4sv0vfo : add - 2. #u52c5mi247 : add - 3. #4hqp1f8m4t : builtins.merge + 1. #bu1ni2nh4n : add + 2. #a0efcgu3if : add + 3. #2t9dm55015 : builtins.merge 4. #sjg2v58vn2 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index f4eb61a788..903bec803a 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - □ #1j4m54701m (start of history) + □ #a1l0ads644 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - ⊙ #c1nv5mm0nq + ⊙ #d4pjujecp5 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #a01ahtlahp + ⊙ #36p4l2nurp > Moves: Original name New name Nat.+ Nat.frobnicate - □ #1j4m54701m (start of history) + □ #a1l0ads644 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - ⊙ #c1nv5mm0nq + ⊙ #d4pjujecp5 > Moves: Original name New name Nat.frobnicate Nat.+ - ⊙ #a01ahtlahp + ⊙ #36p4l2nurp > Moves: Original name New name Nat.+ Nat.frobnicate - □ #1j4m54701m (start of history) + □ #a1l0ads644 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - □ #1j4m54701m (start of history) + □ #a1l0ads644 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - ⊙ #bof572e8h8 + ⊙ #q2j8o0ianj - Deletes: Nat.* Nat.+ - □ #1j4m54701m (start of history) + □ #a1l0ads644 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history.