Merge pull request #117 from unisonweb/topic/searchengine

"Working" search engine example

.gitignore

@@ -10,7 +10,9 @@ cabal-dev
 **/cache/**
 **/build/**
 store
+codestore
 tags
+unison-src/.loaded
 **cabal.sandbox.config
 .cabal-sandbox/**
 

editor/src/Unison/TermSearchboxParser.hs

@@ -16,7 +16,7 @@ import qualified Data.Text as Text
 import qualified Unison.Term as E
 import qualified Unison.Var as Var
 
-term :: Parser [Term V]
+term :: Parser () [Term V]
 term =
   msum
     [ single . E.lit . E.Text . Text.pack <$> quotedString
@@ -30,22 +30,22 @@ term =
   where
   single x = [x]
 
-digits :: Parser String
+digits :: Parser () String
-digits = takeWhile Char.isDigit
+digits = takeWhile "digits" Char.isDigit
 
-digits1 :: Parser String
+digits1 :: Parser () String
 digits1 = (:) <$> one Char.isDigit <*> digits
 
-floatingPoint :: Parser Double
+floatingPoint :: Parser () Double
 floatingPoint = do
   d <- digits1
   rest <- optional (void (char '.') *> ((++) <$> pure "0." <*> (fromMaybe "0" <$> optional digits1)))
   pure $ read d + fromMaybe 0.0 (read <$> rest)
 
-quotedString :: Parser String
+quotedString :: Parser () String
-quotedString = char '\"' *> takeWhile (\c -> c /= '\"') <* optional (char '\"')
+quotedString = char '\"' *> takeWhile "quoted string" (\c -> c /= '\"') <* optional (char '\"')
 
-intro :: Parser [Term V]
+intro :: Parser () [Term V]
 intro = do
   let sym = (Var.named . Text.pack <$> token (identifier [])) <|> pure (Var.named "_")
   let lam v = E.lam v E.blank

node/src/Container.hs

@@ -1,5 +1,7 @@
 {-# Language BangPatterns #-}
 {-# Language OverloadedStrings #-}
+{-# Language PartialTypeSignatures #-}
+{-# Language CPP #-}
 
 module Main where
 
@@ -9,11 +11,11 @@ import Data.Bytes.Serial (serialize)
 import Data.Text.Encoding (decodeUtf8)
 import Network.HTTP.Types.Method (StdMethod(OPTIONS))
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import System.IO (hSetBinaryMode, hFlush, stdin)
+import System.IO (stdout)
-import System.Process as P
+import Unison.Hash (Hash)
 import Unison.NodeProtocol.V0 (protocol)
 import Unison.NodeServer as NS
-import Unison.Parsers (unsafeParseTermWithPrelude)
+import Unison.Parsers (unsafeParseTerm)
 import Unison.Runtime.Lock (Lock(..),Lease(..))
 import Web.Scotty as S
 import qualified Data.ByteArray as BA
@@ -21,54 +23,111 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.Bytes.Put as Put
+import qualified Data.Set as Set
 import qualified Data.Text as Text
-import qualified Unison.BlockStore.FileBlockStore as FBS
+import qualified Unison.Config as Config
+import qualified Unison.Cryptography as Cryptography
+import qualified Unison.Node as Node
+import qualified Unison.Node.BasicNode as BasicNode
+import qualified Unison.Node.Builtin as Builtin
+import qualified Unison.Node.MemStore as Store
 import qualified Unison.NodeContainer as C
 import qualified Unison.NodeProtocol as NP
-import qualified Unison.Remote as R
+import qualified Unison.NodeWorker as NW
+import qualified Unison.Note as Note
+import qualified Unison.Parsers as Parsers
+import qualified Unison.Remote as Remote
+import qualified Unison.Runtime.ExtraBuiltins as ExtraBuiltins
 import qualified Unison.Runtime.Multiplex as Mux
+import qualified Unison.Runtime.Remote as Remote
+import qualified Unison.SerializationAndHashing as SAH
+import qualified Unison.Term as Term
 import qualified Unison.Typechecker.Components as Components
+import qualified Unison.Util.Logger as L
+
+#ifdef leveldb
+import qualified Unison.BlockStore.LevelDbStore as LDBS
+#else
+import qualified Unison.BlockStore.FileBlockStore as FBS
+#endif
 
 main :: IO ()
-main = Mux.uniqueChannel >>= \rand ->
+main = do
-  let
+  logger <- Config.loggerTo stdout
-    fileBS = FBS.make' rand h "blockstore"
+  rand <- Mux.uniqueChannel
-    h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
+  let h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
-    locker _ = pure held
+#ifdef leveldb
-    held = Lock (pure (Just (Lease (pure True) (pure ()))))
+  putStrLn "using leveldb-based block store"
-    mkNode _ = do -- todo: actually use node params
+  blockstore <- LDBS.make rand h "blockstore.leveldb"
-      publicKey <- Put.runPutS . serialize <$> rand
+#else
-      pure $ R.Node "localhost" publicKey
+  putStrLn "using file-based block store"
-    launchNode node = do
+  blockstore <- FBS.make' rand h "blockstore"
-      (Just stdin, Just stdout, Just stderr, handle) <- P.createProcess_ "node-worker" cmd
+#endif
-      hSetBinaryMode stdin True
+  let !b0 = Builtin.makeBuiltins logger
-      B.hPut stdin . Put.runPutS $ do
+  let !crypto = Cryptography.noop "todo-real-public-key"
-        serialize ("ignored-private-key" :: B.ByteString)
+  b1 <- ExtraBuiltins.make logger blockstore crypto
-        serialize node
+  store <- Store.make
-        serialize (R.Universe "local-universe")
+  backend <- BasicNode.make SAH.hash store (\whnf -> b0 whnf ++ b1 whnf)
-        serialize B.empty -- no sandbox specification
+  loadDeclarations logger "unison-src/base.u" backend
-      hFlush stdin
+  loadDeclarations logger "unison-src/extra.u" backend
-      let proof = "not-real-delete-proof"
+  loadDeclarations logger "unison-src/dindex.u" backend
-      pure (stdin, stdout, stderr, handle, proof)
+  let locker _ = pure held
-    cmd = (P.shell "stack exec worker") {
+      held = Lock (pure (Just (Lease (pure True) (pure ()))))
-        P.std_out = P.CreatePipe,
+      mkNode _ = do -- todo: actually use node params
-        P.std_in = P.CreatePipe,
+        publicKey <- Put.runPutS . serialize <$> rand
-        P.std_err = P.CreatePipe }
+        pure $ Remote.Node "localhost" publicKey
-  in do
+      lang :: Remote.Language SAH.TermV Hash
-    fileBS <- fileBS
+      lang = Remote.Language localDependencies eval Term.app Term.node
-    send <- C.make fileBS locker protocol mkNode launchNode
+                             (Term.builtin "()") Term.channel local unRemote Term.remote
-    S.scotty 8081 $ do
+      local l = Term.remote (Remote.Step (Remote.Local l))
-      S.middleware logStdoutDev
+      unRemote (Term.Distributed' (Term.Remote r)) = Just r
-      S.addroute OPTIONS (S.regex ".*") $ NS.originOptions
+      unRemote _ = Nothing
-      NS.postRoute "/compute/:nodepk" $ do
+      codestore = Remote.makeCodestore blockstore :: Remote.Codestore SAH.TermV Hash
-        nodepk <- S.param "nodepk"
+      localDependencies _ = Set.empty -- todo, compute this for real
-        let node = R.Node "localhost" (Put.runPutS . serialize . Base64.decodeLenient $ nodepk)
+      whnf e = do -- todo: may want to have this use evaluator + codestore directly
-        programtxt <- S.body
+        [(_,_,e)] <- Node.evaluateTerms backend [([], e)]
-        let programstr = Text.unpack (decodeUtf8 (LB.toStrict programtxt))
+        pure e
-        let !prog = unsafeParseTermWithPrelude programstr
+      eval t = Note.run (whnf t)
-        let !prog' = Components.minimize' prog
+      -- evaluator = I.eval allprimops
-        liftIO . putStrLn $ "parsed " ++ show prog
+      -- allbuiltins = b0 whnf ++ b1 whnf
-        liftIO . putStrLn $ "parsed' " ++ show prog'
+      -- allprimops = Map.fromList [ (r, op) | Builtin.Builtin r (Just op) _ _ <- allbuiltins ]
-        let destination = Put.runPutS (serialize node)
+      typecheck e = do
-        let pk = Mux.Packet (Mux.channelId $ NP._localEval protocol) (Put.runPutS (serialize prog'))
+        bindings <- Note.run $ Node.allTermsByVarName Term.ref backend
-        liftIO $ send (Mux.Packet destination (Put.runPutS (serialize pk)))
+        L.debug logger $ "known symbols: " ++ show (map fst bindings)
+        let e' = Parsers.bindBuiltins bindings [] e
+        Note.unnote (Node.typeAt backend e' []) >>= \t -> case t of
+          Left note -> pure $ Left (show note)
+          Right _ -> pure (Right e')
+      launchNode logger node = do
+        let u = Remote.Universe "local-universe"
+        L.debug logger $ "launching node..."
+        (send, recv, isActive) <- NW.make logger protocol crypto lang node u typecheck
+        L.debug logger $ "...launched node"
+        let proof = "todo: real-delete-proof, based on node private key"
+        pure (send, recv, isActive, proof)
+
+  send <- C.make blockstore locker protocol mkNode launchNode
+  S.scotty 8081 $ do
+    S.middleware logStdoutDev
+    S.addroute OPTIONS (S.regex ".*") $ NS.originOptions
+    NS.postRoute "/compute/:nodepk" $ do
+      nodepk <- S.param "nodepk"
+      let node = Remote.Node "localhost" (Put.runPutS . serialize . Base64.decodeLenient $ nodepk)
+      programtxt <- S.body
+      let programstr = Text.unpack (decodeUtf8 (LB.toStrict programtxt))
+      let !prog = unsafeParseTerm programstr
+      let !prog' = Components.minimize' prog
+      liftIO $ L.info logger "parsed"
+      let destination = Put.runPutS (serialize node)
+      let pk = Mux.Packet (Mux.channelId $ NP._localEval protocol) (Put.runPutS (serialize prog'))
+      liftIO $ send (Mux.Packet destination (Put.runPutS (serialize pk)))
+
+loadDeclarations logger path node = do
+  txt <- decodeUtf8 <$> B.readFile path
+  let str = Text.unpack txt
+  r <- Note.run $ Node.declare' Term.ref str node
+  L.info logger $ "loaded " ++ path
+  L.debug' logger $ do
+    ts <- Note.run $ Node.allTermsByVarName Term.ref node
+    pure $ show ts
+  pure r

node/src/Node.hs

@@ -3,6 +3,7 @@
 
 module Main where
 
+import System.IO
 import Unison.Hash.Extra ()
 import Unison.Node.Store (Store)
 import Unison.Reference (Reference)
@@ -26,6 +27,7 @@ import qualified Unison.Runtime.ExtraBuiltins as EB
 import qualified Unison.Symbol as Symbol
 import qualified Unison.Term as Term
 import qualified Unison.View as View
+import qualified Unison.Util.Logger as L
 
 hash :: Var v => Term.Term v -> Reference
 hash (Term.Ref' r) = r
@@ -43,10 +45,12 @@ makeRandomAddress crypt = Address <$> C.randomBytes crypt 64
 
 main :: IO ()
 main = do
+  mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr]
   store' <- store
+  logger <- L.atomic (L.atInfo L.toStandardError)
   let crypto = C.noop "dummypublickey"
   blockStore <- FBS.make' (makeRandomAddress crypto) makeAddress "Index"
-  keyValueOps <- EB.makeAPI blockStore crypto
+  keyValueOps <- EB.make logger blockStore crypto
-  let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
+  let makeBuiltins whnf = concat [Builtin.makeBuiltins logger whnf, keyValueOps whnf]
   node <- BasicNode.make hash store' makeBuiltins
   NodeServer.server 8080 node

node/src/Unison/Node/UnisonBlockStore.hs

@@ -57,11 +57,11 @@ make bs = let
     StoreData trm tym (Map.insert ref met mm)
   in do
   journaledStore <- J.fromBlocks bs apply keyframeBlock updateBlock
-  let readTerm h = Note.noted . atomically $ (maybeToEither (Note.note "term not found") . Map.lookup h . termMap)
+  let readTerm h = Note.noted . atomically $ (maybeToEither (Note.note $ "term not found " ++ show h) . Map.lookup h . termMap)
         <$> J.get journaledStore
-      typeOfTerm r = Note.noted . atomically $ (maybeToEither (Note.note "type not found") . Map.lookup r . annotationMap)
+      typeOfTerm r = Note.noted . atomically $ (maybeToEither (Note.note $ "type not found " ++ show r) . Map.lookup r . annotationMap)
         <$> J.get journaledStore
-      readMetadata r = Note.noted . atomically $ (maybeToEither (Note.note "metadata not found") . Map.lookup r . metadataMap)
+      readMetadata r = Note.noted . atomically $ (maybeToEither (Note.note $ "metadata not found " ++ show r) . Map.lookup r . metadataMap)
         <$> J.get journaledStore
       writeTerm h t = Note.lift $ J.update (WriteTerm h t) journaledStore
       annotateTerm r t = Note.lift $ J.update (AnnotateTerm r t) journaledStore

node/src/Unison/NodeContainer.hs

@@ -1,24 +1,27 @@
+{-# Language DeriveGeneric #-}
 {-# Language OverloadedStrings #-}
 
 module Unison.NodeContainer where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.Chan.Unagi
+import Control.Concurrent.STM (STM)
 import Control.Exception
 import Control.Monad
 import Data.ByteString (ByteString)
+import Data.Bytes.Serial (Serial)
 import Data.IORef
-import System.IO (hClose, hFlush, Handle)
+import GHC.Generics
 import Unison.Runtime.Remote ()
 import qualified Control.Concurrent.Async as Async
+import qualified Control.Concurrent.STM as STM
 import qualified Data.ByteString as B
+import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.Bytes.Get as Get
 import qualified Data.Bytes.Put as Put
 import qualified Data.Bytes.Serial as S
 import qualified Data.Trie as Trie
-import qualified System.Exit as Exit
-import qualified System.Process as Process
 import qualified Unison.BlockStore as BS
 import qualified Unison.Config as Config
 import qualified Unison.NodeProtocol as P
@@ -30,19 +33,22 @@ import qualified Unison.Util.Logger as L
 type Trie = Trie.Trie
 type DeleteProof = ByteString
 
+data Keypair k = Keypair { public :: k, private :: B.ByteString } deriving Generic
+instance Serial k => Serial (Keypair k)
+
 make :: (Ord h, S.Serial h, S.Serial hash)
      => BS.BlockStore h
      -> (Remote.Node -> IO L.Lock)
      -> P.Protocol term hash h thash
      -> (ByteString -> IO Remote.Node)
-     -> (Remote.Node -> IO (Handle, Handle, Handle, Process.ProcessHandle, DeleteProof))
+     -> (L.Logger -> Remote.Node -> IO (Maybe Mux.Packet -> IO (), IO (Maybe Mux.Packet), STM Bool, DeleteProof))
      -> IO (Mux.Packet -> IO ())
-make bs nodeLock p genNode launchNodeCmd = do
+make bs nodeLock p genNode launchNode = do
   logger <- L.scope "container" <$> Config.loggerStandardOut
   -- packet queue, processed by main `go` loop below
   (packetWrite, packetRead) <- newChan :: IO (InChan Mux.Packet, OutChan Mux.Packet)
   -- routing trie for packets; initially empty
-  routing <- newIORef (Trie.empty :: Trie (ByteString -> IO ()))
+  routing <- newIORef (Trie.empty :: Trie (Mux.Packet -> IO ()))
   (writeChan packetWrite <$) . forkIO $
     let
       go = forever $ do
@@ -67,45 +73,44 @@ make bs nodeLock p genNode launchNodeCmd = do
                     Nothing -> pure ()
                     Just lease -> do
                       L.info logger $ "waking up node " ++ show node
-                      wakeup node [Mux.content packet] `finally` L.release lease
+                      wakeup node packet `finally` L.release lease
           Just dest -> do
             L.debug logger "destination exists; routing"
-            safely (dest (Mux.content packet))
+            safely (dest packet)
 
       nodeSeries node = BS.Series $ "node-" `mappend` Remote.publicKey node
 
-      wakeup node packets = do
+      wakeup node packet = do
         -- important: we return immediately to main loop after establishing buffer
-        -- to hold packets sent to this node. Actual node process is launched asynchronously
+        -- to hold packets sent to this node. Actual node thread launched asynchronously
         -- and will draw down this buffer
-        (toNodeWrite, toNodeRead) <- newChan :: IO (InChan ByteString, OutChan ByteString)
+        (toNodeWrite, toNodeRead) <- newChan :: IO (InChan (Maybe Mux.Packet), OutChan (Maybe Mux.Packet))
         logger <- pure $ L.scope (show . Base64.encode . Remote.publicKey $ node) logger
-        let send bytes = writeChan toNodeWrite bytes
+        let send pk = case Get.runGetS S.deserialize (Mux.content pk) of
-        let nodebytes = Put.runPutS $ S.serialize node
+              Left err -> L.warn logger $ "packet decoding error: " ++ err
+              Right pk -> writeChan toNodeWrite (Just pk)
+            nodebytes = Put.runPutS $ S.serialize node
         atomicModifyIORef routing $ \t -> (Trie.insert nodebytes send t, ())
-        forM_ packets send
+        send packet
         let removeRoute = atomicModifyIORef' routing $ \t -> (Trie.delete nodebytes t, ())
 
-        -- spin up a new process for the node, which we will communicate with over standard input/output
+        -- spin up a new thread for the node
         void . forkIO . handle (\e -> L.warn logger (show (e :: SomeException)) >> removeRoute) $ do
-          (stdin, stdout, stderr, process, deleteProof) <- launchNodeCmd node
+          L.debug logger "waking.."
-          L.logHandleAt logger L.errorLevel stderr
+          (write, read, isActive, deleteProof) <- launchNode logger node
-          -- read from the process as quickly as possible, buffering input in a queue
+          L.debug logger "awakened"
-          (fromNodeWrite, fromNodeRead) <- newChan
+
-            :: IO (InChan (Maybe Mux.Packet), OutChan (Maybe Mux.Packet))
+          -- deregister the node when idle
-          let write a _ = writeChan fromNodeWrite a
+          _ <- Async.async $ do
-          reader <- Async.async $ Mux.deserializeHandle stdout B.empty write
+            STM.atomically $ do a <- isActive; when a STM.retry
-          -- now that we have a handle to the process, we write to it from the `toNodeRead` queue
+            L.info logger "node idle, removing route"
+            removeRoute
+
+          -- thread for writing to the node, just processes the `toNodeRead` queue
           writer <- Async.async . forever $ do
-            (bytes, force) <- tryReadChan toNodeRead
+            pk <- readChan toNodeRead
-            bytes <- tryRead bytes >>= \bytes -> case bytes of
+            L.debug logger $ "writing packet: " ++ show pk
-              Nothing -> hFlush stdin >> force -- flush buffer whenever there's a pause
+            write pk
-              Just bytes -> pure bytes -- we're saturating the channel, no need to flush manually
-            let nodeBytes = Put.runPutS (S.serialize node)
-            L.trace logger $ "writing bytes " ++ show (B.length bytes)
-            safely $
-              B.hPut stdin bytes `onException`
-              writeChan packetWrite (Mux.Packet nodeBytes bytes)
 
           -- establish routes for processing packets coming from the node
           routes <- id $
@@ -125,8 +130,10 @@ make bs nodeLock p genNode launchNodeCmd = do
               handleRequest :: (S.Serial a, S.Serial b) => (a -> IO b) -> ByteString -> IO ()
               handleRequest h bytes = safely $ do
                 (a, replyTo) <- either fail pure (Get.runGetS S.deserialize bytes)
+                L.debug logger $ "got request " ++ show (Base64.encode replyTo)
                 b <- h a
-                send $ Put.runPutS (S.serialize (Mux.Packet replyTo $ Put.runPutS (S.serialize b)))
+                L.debug logger $ "got response " ++ show (Base64.encode replyTo)
+                writeChan toNodeWrite . Just . Mux.Packet replyTo $ Put.runPutS (S.serialize b)
               insert = handleRequest (BS.insert bs)
               lookup = handleRequest (BS.lookup bs)
               declare = handleRequest (BS.declareSeries bs)
@@ -141,15 +148,16 @@ make bs nodeLock p genNode launchNodeCmd = do
                 h0 <- BS.declareSeries bs series
                 Just _ <- BS.update bs series h0 nodeParams
                 pure node
-              delete proof | proof /= deleteProof = pure ()
+              delete proof | BA.constEq proof deleteProof = pure ()
                            | otherwise  = do
-                send (Put.runPutS $ S.serialize (Nothing :: Maybe Mux.Packet))
+                writeChan toNodeWrite Nothing
                 BS.deleteSeries bs (BS.Series $ Remote.publicKey node)
                 removeRoute
             in pure routes
 
           processor <- Async.async . Mux.repeatWhile $ do
-            nodePacket <- readChan fromNodeRead
+            L.debug logger $ "processor about to read"
+            nodePacket <- read
             case nodePacket of
               Nothing -> False <$ L.info logger "processor completed"
               Just packet -> True <$ do
@@ -163,17 +171,11 @@ make bs nodeLock p genNode launchNodeCmd = do
                     writeChan packetWrite packet -- forwarded to main loop
 
           _ <- forkIO $ do
-            exitCode <- Process.waitForProcess process
+            r <- Async.waitCatch processor
-            L.debug logger "worker process terminated"
+            L.debug logger $ "worker process terminated with: " ++ show r
-            removeRoute
+            _ <- Async.waitCatch writer
-            _ <- Async.waitCatch reader
+            L.debug logger "worker writer thread terminated"
-            L.debug logger "worker reader thread terminated"
+
-            Async.cancel writer
-            _ <- Async.waitCatch processor
-            mapM_ (safely . hClose) [stdin, stdout]
-            case exitCode of
-              Exit.ExitSuccess -> L.info logger $ "node process terminated"
-              Exit.ExitFailure n -> L.warn logger $ "node process exited with: " ++ show n
           pure ()
 
       safely :: IO () -> IO ()

node/src/Unison/NodeProtocol.hs

@@ -53,17 +53,17 @@ data Protocol term signature hash thash =
 blockStoreProxy :: (Serial hash) => Protocol term signature hash thash -> Mux.Multiplex (BlockStore hash)
 blockStoreProxy p = go <$> Mux.ask
   where
-  timeout = 5000000 :: Mux.Microseconds
+  timeout = Mux.seconds 25
   go env =
     let
-      mt :: (Serial a, Serial b) => Request a b -> a -> IO b
+      mt :: (Serial a, Serial b) => String -> Request a b -> a -> IO b
-      mt chan a = Mux.run env . join $ Mux.requestTimed timeout chan a
+      mt msg chan a = Mux.run env . join $ Mux.requestTimed msg timeout chan a
-      insert bytes = mt (_insert p) bytes
+      insert bytes = mt "BlockStore.insert" (_insert p) bytes
-      lookup h = mt (_lookup p) h
+      lookup h = mt "BlockStore.lookup" (_lookup p) h
-      declare series = mt (_declare p) series
+      declare series = mt "BlockStore.declare" (_declare p) series
-      delete series = mt (_delete p) series
+      delete series = mt "BlockStore.delete" (_delete p) series
-      update series h bytes = mt (_update p) (series,h,bytes)
+      update series h bytes = mt "BlockStore.update" (_update p) (series,h,bytes)
-      append series h bytes = mt (_append p) (series,h,bytes)
+      append series h bytes = mt "BlockStore.append" (_append p) (series,h,bytes)
-      resolve series = mt (_resolve p) series
+      resolve series = mt "BlockStore.resolve" (_resolve p) series
-      resolves series = mt (_resolves p) series
+      resolves series = mt "BlockStore.resolves" (_resolves p) series
     in BlockStore insert lookup declare delete update append resolve resolves

node/src/Unison/NodeWorker.hs

@@ -4,32 +4,23 @@
 
 module Unison.NodeWorker where
 
-import Control.Concurrent.STM (atomically)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM (STM, atomically)
 import Control.Concurrent.STM.TSem
+import Control.Exception.Base as Ex
 import Control.Monad.IO.Class
-import Data.Bytes.Serial (Serial, serialize, deserialize)
+import Data.Bytes.Serial (Serial, serialize)
-import Data.Serialize.Get (Get)
-import GHC.Generics
-import System.IO (stdin, hSetBinaryMode)
-import Unison.BlockStore (BlockStore(..))
 import Unison.Cryptography (Cryptography)
 import Unison.Hash.Extra ()
+import qualified Control.Concurrent.Async as Async
 import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.Bytes.Get as Get
 import qualified Data.Bytes.Put as Put
-import qualified Data.Serialize.Get as Get
-import qualified Unison.Config as Config
-import qualified Unison.Cryptography as C
 import qualified Unison.NodeProtocol as P
 import qualified Unison.Remote as Remote
 import qualified Unison.Runtime.Multiplex as Mux
 import qualified Unison.Runtime.Remote as Remote
 import qualified Unison.Util.Logger as L
 
-data Keypair k = Keypair { public :: k, private :: B.ByteString } deriving Generic
-instance Serial k => Serial (Keypair k)
-
 make :: ( BA.ByteArrayAccess key
         , Serial signature
         , Serial term, Show term
@@ -39,37 +30,55 @@ make :: ( BA.ByteArrayAccess key
         , Eq h
         , Serial key
         , Ord thash)
-     => P.Protocol term hash h thash
+     => L.Logger
-     -> (Keypair key -> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext)
+     -> P.Protocol term hash h thash
-     -> Get (Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
+     -> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
-             -> BlockStore h
+     -> Remote.Language term thash
-             -> IO (Remote.Language term thash, term -> IO (Either String ())))
+     -> Remote.Node
-     -> IO ()
+     -> Remote.Universe
-make protocol mkCrypto makeSandbox = do
+     -> (term -> IO (Either String term))
-  logger <- L.scope "worker" <$> Config.loggerStandardError
+     -> IO (Maybe Mux.Packet -> IO (), IO (Maybe Mux.Packet), STM Bool)
-  let die msg = liftIO $ L.error logger msg >> error ""
+make logger protocol crypto sandbox node universe typecheck = do
-  L.info logger $ "initializing... "
+  logger <- pure $ L.scope "worker" logger
-  hSetBinaryMode stdin True
+  (env, toNode, fromNode, isActive) <- Mux.env0 logger
-  (privateKey, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize B.empty)
+  L.debug' logger $ do
-  (node, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
+    active <- atomically isActive
-  (universe, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
+    pure $ "active0: " ++ show active
-  (sandbox, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
+  -- used to make sure we are listening on all channels before returning,
-  publicKey <- either die pure $ Get.runGetS deserialize (Remote.publicKey node)
+  -- otherwise the caller could experience packet drops when sending
-  let keypair = Keypair publicKey privateKey
+  ok <- atomically $ newTSem 0 -- incremented once initialization done
-  L.debug logger $ "remaining bytes: " ++ show (B.length rem)
+  L.debug logger "kicking off processor"
-  interrupt <- atomically $ newTSem 0
+  node <- processor ok env
-  Mux.runStandardIO logger (Mux.seconds 5) rem (atomically $ waitTSem interrupt) $ do
+  _ <- Async.async $ supervise ok env node
+  L.debug logger "about to wait on semaphore"
+  atomically $ waitTSem ok
+  L.debug logger "done waiting on semaphore"
+  threadDelay (1000 * 500)
+  L.debug' logger $ do
+    active <- atomically isActive
+    pure $ "active: " ++ show active
+  let toNode' pk = check >> toNode pk
+      fromNode' = check >> fromNode
+      check = atomically isActive >>= \a ->
+                if a then pure () else fail "inactive node"
+  pure (toNode', fromNode', isActive)
+  where
+  supervise ok env node = Async.waitCatch node >>= \e -> case e of
+    Left err | isCatchable err -> do
+      L.warn logger $ "error during node processing, restarting "
+      node <- processor ok env
+      supervise ok env node
+    Left err ->
+      L.info logger $ "shutting down node due to uncatchable error: " ++ show err
+    Right _ ->
+      L.info logger "shutting down node due to graceful termination"
+  processor ok env = Async.async . Mux.run env $ do
     blockStore <- P.blockStoreProxy protocol
-    makeSandbox <- either die pure $ Get.runGetS makeSandbox sandbox
-    let crypto = mkCrypto keypair
-    (sandbox, typecheck) <- liftIO $ makeSandbox crypto blockStore
-    let skHash = Put.runPutS (serialize $ C.hash crypto [Put.runPutS (serialize $ private keypair)])
     -- todo: load this from persistent store also
     connectionSandbox <- pure $ Remote.ConnectionSandbox (\_ -> pure True) (\_ -> pure True)
     env <- liftIO $ Remote.makeEnv universe node blockStore
-    Mux.info $ "... done initializing"
+    server <- Remote.server crypto connectionSandbox env sandbox protocol
-    _ <- Remote.server crypto connectionSandbox env sandbox protocol
+    localEval <- do
-    _ <- do
       (prog, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._localEval protocol)
       Mux.fork . Mux.scope "_localEval" . Mux.repeatWhile $ do
         e <- prog
@@ -83,24 +92,34 @@ make protocol mkCrypto makeSandbox = do
                 Mux.warn $ "typechecking failed on: " ++ show r
                 Mux.warn $ "typechecking error:\n" ++ err
                 pure True
-              Right _ -> do
+              Right r -> do
                 Mux.debug "typechecked"
                 r <- liftIO $ Remote.eval sandbox r
                 Mux.debug $ "evaluated to " ++ show r
                 case Remote.unRemote sandbox r of
                   Nothing -> True <$ (Mux.warn $ "received a non-Remote: " ++ show r)
                   Just r -> True <$ Mux.fork (Remote.handle crypto connectionSandbox env sandbox protocol r)
-    _ <- do
+    destroyIn <- do
-      (destroy, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._destroyIn protocol)
+      (destroy, _) <- Mux.subscribeTimed (Mux.seconds 60) (P._destroyIn protocol)
       Mux.fork . Mux.repeatWhile $ do
         sig <- destroy
         case sig of
-          Just sig | BA.constEq skHash (Put.runPutS (serialize sig)) -> do
+          Just sig -> do
-            cancel
+            -- cancel
-            Mux.send (Mux.Channel Mux.Type skHash) ()
+            Mux.send (Mux.Channel Mux.Type (Put.runPutS (serialize sig))) ()
             -- no other cleanup needed; container will reclaim resources and eventually
             -- kill off linked child nodes
-            liftIO $ atomically (signalTSem interrupt)
             pure False
           _ -> pure True
-    pure ()
+    Mux.info $ "... done initializing"
+    liftIO . atomically $ signalTSem ok
+    liftIO $ do Async.wait server; Async.wait localEval; Async.wait destroyIn
+
+-- Don't catch asynchronous exceptions or deadlocks
+isCatchable :: SomeException -> Bool
+isCatchable e = not $
+  (case Ex.fromException e of Just Ex.ThreadKilled -> True; _ -> False) ||
+  (case Ex.fromException e of Just Ex.UserInterrupt -> True; _ -> False) ||
+  (case Ex.fromException e of Just Ex.BlockedIndefinitelyOnSTM -> True; _ -> False) ||
+  (case Ex.fromException e of Just Ex.BlockedIndefinitelyOnMVar -> True; _ -> False)
+

node/src/Unison/Remote/Extra.hs

@@ -11,6 +11,6 @@ instance Serial1 Step
 instance Serial1 Local
 instance Serial t => Serial (Step t)
 instance Serial t => Serial (Local t)
-instance Serial Timeout
+instance Serial Duration
 instance Serial Node
 instance Serial Channel

node/src/Unison/Runtime/ExtraBuiltins.hs

@@ -10,10 +10,13 @@ import Unison.BlockStore (Series(..), BlockStore)
 import Unison.Node.Builtin
 import Unison.Parsers (unsafeParseType)
 import Unison.Type (Type)
+import Unison.Util.Logger (Logger)
 import qualified Data.Text as Text
 import qualified Data.Vector as Vector
+import qualified Network.URI as URI
 import qualified Unison.Cryptography as C
 import qualified Unison.Eval.Interpreter as I
+import qualified Unison.Hash as Hash
 import qualified Unison.Note as Note
 import qualified Unison.Reference as R
 import qualified Unison.Remote as Remote
@@ -24,6 +27,7 @@ import qualified Unison.Runtime.ResourcePool as RP
 import qualified Unison.SerializationAndHashing as SAH
 import qualified Unison.Term as Term
 import qualified Unison.Type as Type
+-- import qualified Unison.Util.Logger as L
 
 indexT :: Ord v => Type v -> Type v -> Type v
 indexT k v = Type.ref (R.Builtin "Index") `Type.app` k `Type.app` v
@@ -32,10 +36,10 @@ index :: Remote.Node -> Term.Term V -> Term.Term V
 index node h = Term.ref (R.Builtin "Index") `Term.apps` [Term.node node, h]
 
 linkT :: Ord v => Type v
-linkT = Type.ref (R.Builtin "Link")
+linkT = Type.ref (R.Builtin "Html.Link")
 
 link :: Term.Term V -> Term.Term V -> Term.Term V
-link href description = Term.ref (R.Builtin "Link") `Term.app` href `Term.app` description
+link href description = Term.ref (R.Builtin "Html.Link") `Term.app` href `Term.app` description
 
 linkToTerm :: Html.Link -> Term.Term V
 linkToTerm (Html.Link href description) = link (Term.lit $ Term.Text href)
@@ -46,29 +50,82 @@ pattern Index' node s <-
             (Term.Text' s)
 
 pattern Link' href description <-
-  Term.App' (Term.App' (Term.Ref' (R.Builtin "Link"))
+  Term.App' (Term.App' (Term.Ref' (R.Builtin "Html.Link"))
                        (Term.Text' href))
   (Term.Text' description)
 
 -- TODO rewrite builtins not to use unsafe code
-makeAPI :: Eq a => BlockStore a -> C.Cryptography k syk sk skp s h ByteString
+make :: Eq a
-  -> IO (WHNFEval -> [Builtin])
+     => Logger -> BlockStore a -> C.Cryptography k syk sk skp s h ByteString
-makeAPI blockStore crypto = do
+     -> IO (WHNFEval -> [Builtin])
+make _ blockStore crypto = do
   let nextID = do
         cp <- C.randomBytes crypto 64
         ud <- C.randomBytes crypto 64
         pure (Series cp, Series ud)
   resourcePool <- RP.make 3 10 (Index.loadEncrypted blockStore crypto) Index.flush
   pure (\whnf -> map (\(r, o, t, m) -> Builtin r o t m)
-     [ let r = R.Builtin "Index.unsafeEmpty"
+     [ -- Index
+       let r = R.Builtin "Index.empty#"
            op [self] = do
              ident <- Note.lift nextID
              Term.Distributed' (Term.Node self) <- whnf self
              pure . index self . Term.lit . Term.Text . Index.idToText $ ident
-           op _ = fail "Index.unsafeEmpty unpossible"
+           op _ = fail "Index.empty# unpossible"
-           type' = unsafeParseType "forall k v. Node -> Index k v"
+           type' = unsafeParseType "forall k v . Node -> Index k v"
-       in (r, Just (I.Primop 1 op), type', prefix "unsafeEmpty")
+       in (r, Just (I.Primop 1 op), type', prefix "Index.empty#")
-     , let r = R.Builtin "Index.unsafeLookup"
+     , let r = R.Builtin "Index.keys#"
+           op [indexToken] = do
+             Term.Text' h <- whnf indexToken
+             Note.lift $ do
+               (db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
+               flip finally cleanup $ do
+                 keyBytes <- atomically $ Index.keys db
+                 case traverse SAH.deserializeTermFromBytes keyBytes of
+                   Left err -> fail ("Index.keys# could not deserialize: " ++ err)
+                   Right terms -> pure $ Term.vector terms
+           op _ = fail "Index.keys# unpossible"
+           type' = unsafeParseType "forall k . Text -> Vector k"
+       in (r, Just (I.Primop 1 op), type', prefix "Index.keys#")
+     , let r = R.Builtin "Index.1st-key#"
+           op [indexToken] = do
+             Term.Text' h <- whnf indexToken
+             Note.lift $ do
+               (db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
+               flip finally cleanup $ do
+                 keyBytes <- atomically $ Index.keys db
+                 case keyBytes of
+                   [] -> pure none
+                   (keyBytes:_) -> case SAH.deserializeTermFromBytes keyBytes of
+                     Left err -> fail ("Index.1st-key# could not deserialize: " ++ err)
+                     Right terms -> pure $ some terms
+           op _ = fail "Index.1st-key# unpossible"
+           type' = unsafeParseType "forall k . Text -> Optional k"
+       in (r, Just (I.Primop 1 op), type', prefix "Index.1st-key#")
+     , let r = R.Builtin "Index.increment#"
+           op [key, indexToken] = do
+             key <- whnf key
+             Term.Text' h <- whnf indexToken
+             Note.lift $ do
+               (db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
+               flip finally cleanup $ do
+                 entry <- atomically $ Index.lookupGT (SAH.hash' key) db
+                 case entry of
+                   Nothing -> pure none
+                   Just (_, (keyBytes, _)) -> case SAH.deserializeTermFromBytes keyBytes of
+                     Left err -> fail ("Index.increment# could not deserialize: " ++ err)
+                     Right term -> pure $ some term
+           op _ = fail "Index.increment# unpossible"
+           type' = unsafeParseType "forall k . k -> Text -> Optional k"
+       in (r, Just (I.Primop 2 op), type', prefix "Index.increment#")
+     , let r = R.Builtin "Index.representation#"
+           op [index] = do
+             Index' node tok <- whnf index
+             pure $ pair' (Term.node node) (Term.text tok)
+           op _ = fail "Index.representation# unpossible"
+           type' = unsafeParseType "forall k v . Index k v -> (Node, Text)"
+       in (r, Just (I.Primop 1 op), type', prefix "Index.representation#")
+     , let r = R.Builtin "Index.lookup#"
            op [key, indexToken] = inject g indexToken key where
              inject g indexToken key = do
                i <- whnf indexToken
@@ -80,80 +137,77 @@ makeAPI blockStore crypto = do
                  flip finally cleanup $ do
                    result <- atomically $ Index.lookup (SAH.hash' k) db
                    case result >>= (pure . SAH.deserializeTermFromBytes . snd) of
-                     Just (Left s) -> fail ("Index.unsafeLookup could not deserialize: " ++ s)
+                     Just (Left s) -> fail ("Index.lookup# could not deserialize: " ++ s)
                      Just (Right t) -> pure $ some t
                      Nothing -> pure none
                pure val
              g s k = pure $ Term.ref r `Term.app` s `Term.app` k
-           op _ = fail "Index.unsafeLookup unpossible"
+           op _ = fail "Index.lookup# unpossible"
-           type' = unsafeParseType "forall k v. k -> Index k v -> Optional v"
+           type' = unsafeParseType "forall k v . k -> Text -> Optional v"
-       in (r, Just (I.Primop 2 op), type', prefix "unsafeLookup")
+       in (r, Just (I.Primop 2 op), type', prefix "Index.lookup#")
-     , let r = R.Builtin "Index.lookup"
+     , let r = R.Builtin "Index.delete#"
-           op [key, index] = do
+           op [key, indexToken] = do
-             Index' node tok <- whnf index
+             Term.Text' indexToken <- whnf indexToken
-             pure $
+             key <- whnf key
-               Term.builtin "Remote.map" `Term.apps` [
+             (db, cleanup) <- Note.lift . RP.acquire resourcePool . Index.textToId $ indexToken
-                 Term.builtin "Index.unsafeLookup" `Term.app` key,
+             Note.lift . flip finally cleanup $ do
-                 Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
+               _ <- atomically $ Index.delete (SAH.hash' key) db
-               ]
-           op _ = fail "Index.lookup unpossible"
-           type' = unsafeParseType "forall k v. k -> Index k v -> Remote (Optional v)"
-       in (r, Just (I.Primop 2 op), type', prefix "lookup")
-     , let r = R.Builtin "Index.unsafeInsert"
-           op [k, v, index] = inject g k v index where
-             inject g k v index = do
-               k' <- whnf k
-               v' <- whnf v
-               s <- whnf index
-               g k' v' s
-             g k v (Term.Text' h) = do
-               Note.lift $ do
-                 (db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
-                 flip finally cleanup $ atomically
-                   (Index.insert (SAH.hash' k) (SAH.serializeTerm k, SAH.serializeTerm v) db)
-                   >>= atomically
                pure unitRef
-             g k v index = pure $ Term.ref r `Term.app` k `Term.app` v `Term.app` index
+           op _ = fail "Index.delete# unpossible"
-           op _ = fail "Index.unsafeInsert unpossible"
+           type' = unsafeParseType "forall k . k -> Text -> Unit"
-           type' = unsafeParseType "forall k v. k -> v -> Index k v -> Unit"
+       in (r, Just (I.Primop 2 op), type', prefix "Index.delete#")
-       in (r, Just (I.Primop 3 op), type', prefix "unsafeInsert")
+     , let r = R.Builtin "Index.insert#"
-     , let r = R.Builtin "Index.insert"
+           op [k, v, index] = do
-           op [key, value, index] = do
+             k <- whnf k
-             Index' node tok <- whnf index
+             v <- whnf v
-             pure $
+             Term.Text' indexToken <- whnf index
-               Term.builtin "Remote.map" `Term.apps` [
+             Note.lift $ do
-                 Term.builtin "Index.unsafeInsert" `Term.apps` [key,value],
+               (db, cleanup) <- RP.acquire resourcePool . Index.textToId $ indexToken
-                 Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
+               flip finally cleanup $ atomically
-               ]
+                 (Index.insert (SAH.hash' k) (SAH.serializeTerm k, SAH.serializeTerm v) db)
-           op _ = fail "Index.insert unpossible"
+                 >>= atomically
-           type' = unsafeParseType "forall k v. k -> v -> Index k v -> Remote Unit"
+               pure unitRef
-       in (r, Just (I.Primop 3 op), type', prefix "insert")
+           op _ = fail "Index.insert# unpossible"
-     , let r = R.Builtin "Html.getLinks"
+           type' = unsafeParseType "forall k v . k -> v -> Text -> Unit"
+       in (r, Just (I.Primop 3 op), type', prefix "Index.insert#")
+
+     -- Html
+     , let r = R.Builtin "Html.get-links"
            op [html] = do
              html' <- whnf html
              pure $ case html' of
                Term.Text' h -> Term.vector' . Vector.fromList . map linkToTerm
                  $ Html.getLinks h
                x -> Term.ref r `Term.app` x
-           op _ = fail "Html.getLinks unpossible"
+           op _ = fail "Html.get-links unpossible"
-       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Link", prefix "getLinks")
+       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Html.Link", prefix "Html.get-links")
-     , let r = R.Builtin "Html.getHref"
+     , let r = R.Builtin "Html.plain-text"
+           op [html] = do
+             html' <- whnf html
+             pure $ case html' of
+               Term.Text' h -> Term.text $ Html.toPlainText h
+               x -> Term.ref r `Term.app` x
+           op _ = fail "Html.plain-text unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Text", prefix "Html.plain-text")
+     , let r = R.Builtin "Html.get-href"
            op [link] = do
              link' <- whnf link
              pure $ case link' of
                Link' href _ -> Term.lit (Term.Text href)
                x -> Term.ref r `Term.app` x
-           op _ = fail "Html.getHref unpossible"
+           op _ = fail "Html.get-href unpossible"
-       in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getHref")
+       in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-href")
-     , let r = R.Builtin "Html.getDescription"
+     , let r = R.Builtin "Html.get-description"
            op [link] = do
              link' <- whnf link
              pure $ case link' of
                Link' _ d -> Term.lit (Term.Text d)
                x -> Term.ref r `Term.app` x
-           op _ = fail "Html.getDescription unpossible"
+           op _ = fail "Html.get-description unpossible"
-       in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getDescription")
+       in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-description")
-     , let r = R.Builtin "Http.unsafeGetURL"
+
+     -- Http
+     , let r = R.Builtin "Http.get-url#"
            op [url] = do
              url <- whnf url
              case url of
@@ -163,11 +217,87 @@ makeAPI blockStore crypto = do
                      Right x -> right $ Term.text x
                      Left x -> left . Term.text . Text.pack $ show x
                x -> pure $ Term.ref r `Term.app` x
-           op _ = fail "Http.unsafeGetURL unpossible"
+           op _ = fail "Http.get-url# unpossible"
-       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "unsafeGetURL")
+       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.get-url#")
-     , let r = R.Builtin "Http.getURL"
+
-           op [url] = pure $ Term.builtin "Remote.pure" `Term.app`
+    , let r = R.Builtin "Uri.parse-scheme"
-             (Term.builtin "Http.unsafeGetURL" `Term.app` url)
+          op [Term.Text' url] = pure $ case URI.parseURI (Text.unpack url) of
-           op _ = fail "Http.getURL unpossible"
+            Nothing -> none
-       in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "getURL")
+            Just uri -> some . Term.text . Text.pack $ URI.uriScheme uri
+          op _ = error "Uri.parse-scheme unpossible"
+          typ = "Text -> Optional Text"
+      in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Uri.parse-scheme")
+
+    , let r = R.Builtin "Uri.parse-authority"
+          op [Term.Text' url] = pure $
+            case URI.parseURI (Text.unpack url) >>= URI.uriAuthority of
+              Nothing -> none
+              Just auth -> some . Term.text . Text.pack $
+                URI.uriUserInfo auth ++ URI.uriRegName auth ++ URI.uriPort auth
+          op _ = error "Uri.parse-authority unpossible"
+          typ = "Text -> Optional Text"
+      in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Uri.parse-authority")
+
+     -- Hashing
+     -- add erase, comparison functions
+     , let r = R.Builtin "hash#"
+           op [e] = do
+             e <- whnf e
+             let h = Hash.base64 . Hash.fromBytes . SAH.hash' $ e
+             pure $ Term.builtin "Hash" `Term.app` (Term.text h)
+           op _ = fail "hash"
+           t = "forall a . a -> Hash a"
+       in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "hash#")
+     , let r = R.Builtin "Hash.base64"
+           op [e] = do
+             Term.App' _ (Term.Text' r1) <- whnf e
+             pure (Term.text r1)
+           op _ = fail "Hash.base64"
+           t = "forall a . Hash a -> Text"
+       in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.base64")
+     , let r = R.Builtin "Hash.erase"
+           op [e] = pure e
+           op _ = fail "Hash.erase"
+           t = "forall a . Hash a -> Hash Unit"
+       in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.erase")
+     , let r = R.Builtin "Hash.=="
+           op [h1,h2] = do
+             Term.App' _ (Term.Text' r1) <- whnf h1
+             Term.App' _ (Term.Text' r2) <- whnf h2
+             pure $ if r1 == r2 then true else false
+           op _ = fail "Hash.=="
+       in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.==")
+     , let r = R.Builtin "Hash.<"
+           op [h1,h2] = do
+             Term.App' _ (Term.Text' r1) <- whnf h1
+             Term.App' _ (Term.Text' r2) <- whnf h2
+             pure $ if r1 < r2 then true else false
+           op _ = fail "Hash.<"
+       in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.<")
+     , let r = R.Builtin "Hash.<="
+           op [h1,h2] = do
+             Term.App' _ (Term.Text' r1) <- whnf h1
+             Term.App' _ (Term.Text' r2) <- whnf h2
+             pure $ if r1 <= r2 then true else false
+           op _ = fail "Hash.<="
+       in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.<=")
+     , let r = R.Builtin "Hash.>"
+           op [h1,h2] = do
+             Term.App' _ (Term.Text' r1) <- whnf h1
+             Term.App' _ (Term.Text' r2) <- whnf h2
+             pure $ if r1 > r2 then true else false
+           op _ = fail "Hash.>"
+       in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.>")
+     , let r = R.Builtin "Hash.>="
+           op [h1,h2] = do
+             Term.App' _ (Term.Text' r1) <- whnf h1
+             Term.App' _ (Term.Text' r2) <- whnf h2
+             pure $ if r1 >= r2 then true else false
+           op _ = fail "Hash.>="
+       in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.>=")
+     , let r = R.Builtin "Hash.Order"
+       in (r, Nothing, unsafeParseType "∀ a . Order (Hash a)", prefix "Hash.Order")
      ])
+
+hashCompareTyp :: Type V
+hashCompareTyp = unsafeParseType "∀ a . Hash a -> Hash a -> Boolean"

node/src/Unison/Runtime/Html.hs

@@ -2,7 +2,7 @@ module Unison.Runtime.Html where
 
 import Data.Maybe (listToMaybe, catMaybes, mapMaybe)
 import Data.Text (Text, toLower, pack)
-import Text.HTML.TagSoup (Tag(..), (~/=), maybeTagText, parseTags)
+import Text.HTML.TagSoup (Tag(..), (~/=), maybeTagText, parseTags, innerText, isTagOpenName, isTagComment, isTagCloseName)
 import qualified Data.Text as Text
 
 data Link = Link { ref :: Text, description :: Text } deriving (Show)
@@ -24,3 +24,17 @@ sectionToLink _ = Nothing
 
 getLinks :: Text -> [Link]
 getLinks s = mapMaybe sectionToLink . justAnchorSections $ parseTags s
+
+toPlainText :: Text -> Text
+toPlainText s = innerText . ignores $ parseTags s
+
+ignores :: [Tag Text] -> [Tag Text]
+ignores = go where
+  script = Text.pack "script"
+  style = Text.pack "style"
+  go [] = []
+  go (hd:tl) = case hd of
+    _ | isTagOpenName script hd -> go (dropWhile (not . isTagCloseName script) tl)
+      | isTagOpenName style hd -> go (dropWhile (not . isTagCloseName style) tl)
+      | isTagComment hd -> go tl
+      | otherwise -> hd : go tl

node/src/Unison/Runtime/Index.hs

@@ -5,7 +5,9 @@ module Unison.Runtime.Index
   ,Unison.Runtime.Index.insert
   ,Unison.Runtime.Index.lookupGT
   ,Unison.Runtime.Index.flush
+  ,entries
   ,idToText
+  ,keys
   ,load
   ,loadEncrypted
   ,textToId
@@ -17,12 +19,12 @@ import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Unison.Cryptography
-import Unison.Runtime.Journal as J
-import Unison.Runtime.JournaledMap as JM
-import qualified Unison.BlockStore as BS
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.Map as Map
+import qualified Unison.BlockStore as BS
+import qualified Unison.Runtime.Journal as J
+import qualified Unison.Runtime.JournaledMap as JM
 
 type KeyHash = ByteString
 type Key = ByteString
@@ -64,6 +66,12 @@ delete kh (Db journaledMap _) = J.updateNowAsyncFlush (JM.Delete kh) journaledMa
 lookup :: KeyHash -> Db -> STM (Maybe (Key, Value))
 lookup kh (Db journaledMap _) = Map.lookup kh <$> J.get journaledMap
 
+entries :: Db -> STM [(Key, Value)]
+entries (Db journaledMap _) = Map.elems <$> J.get journaledMap
+
+keys :: Db -> STM [Key]
+keys db = map fst <$> entries db
+
 -- | Find next key in the Db whose key is greater than the provided key
 lookupGT :: KeyHash -> Db -> STM (Maybe (KeyHash, (Key, Value)))
 lookupGT kh (Db journaledMap _) = Map.lookupGT kh <$> J.get journaledMap

node/src/Unison/Runtime/Multiplex.hs

@@ -5,7 +5,6 @@
 
 module Unison.Runtime.Multiplex where
 
-import System.IO (Handle, stdin, stdout, hFlush, hSetBinaryMode)
 import Control.Applicative
 import Control.Concurrent.Async (Async)
 import Control.Concurrent.MVar
@@ -33,13 +32,10 @@ import qualified Data.ByteArray as BA
 import qualified Data.ByteString as B
 import qualified Data.Bytes.Get as Get
 import qualified Data.Bytes.Put as Put
-import qualified Data.Serialize.Get as Get
 import qualified STMContainers.Map as M
 import qualified Unison.Cryptography as C
 import qualified Unison.Runtime.Queue as Q
 import qualified Unison.Util.Logger as L
-import qualified ListT
-import qualified Control.Monad.Morph as Morph
 
 data Packet = Packet { destination :: !B.ByteString, content :: !B.ByteString } deriving (Generic)
 instance Serial Packet
@@ -53,11 +49,31 @@ type IsSubscription = Bool
 data Callbacks =
   Callbacks (M.Map B.ByteString (B.ByteString -> IO ())) (TVar Word64)
 
-type Env = (STM Packet -> STM (), Callbacks, IO B.ByteString, L.Logger)
+type Env =
+  ( STM Packet -> STM ()
+  , Callbacks
+  , IO B.ByteString
+  , M.Map B.ByteString (Multiplex B.ByteString)
+  , L.Logger)
 
 newtype Multiplex a = Multiplex (ReaderT Env IO a)
   deriving (Applicative, Alternative, Functor, Monad, MonadIO, MonadPlus, MonadReader Env)
 
+env0 :: L.Logger -> IO (Env, Maybe Packet -> IO (), IO (Maybe Packet), STM Bool)
+env0 logger = do
+  fresh <- uniqueChannel
+  output <- atomically Q.empty :: IO (Q.Queue (Maybe Packet))
+  input <- atomically newTQueue :: IO (TQueue (Maybe Packet))
+  cb0@(Callbacks m _) <- Callbacks <$> atomically M.new <*> atomically (newTVar 0)
+  recvs0 <- atomically M.new
+  let env = (Q.enqueue output . (Just <$>), cb0, fresh, recvs0, logger)
+      isActive = (||) <$> (not <$> M.null m) <*> (not <$> M.null recvs0)
+  _ <- run env (fork $ process (atomically (readTQueue input)))
+  pure ( env
+       , atomically . writeTQueue input
+       , atomically $ Q.dequeue output
+       , isActive )
+
 run :: Env -> Multiplex a -> IO a
 run env (Multiplex go) = runReaderT go env
 
@@ -66,113 +82,25 @@ liftLogged msg action = ask >>= \env -> liftIO $ catch action (handle env) where
   handle :: Env -> SomeException -> IO a
   handle env ex = run env (warn $ msg ++ " " ++ show ex) >> throwIO ex
 
--- | Run the multiplexed computation using stdin and stdout, terminating
--- after a period of inactivity exceeding sleepAfter. `rem` is prepended
--- onto stdin.
-runStandardIO :: L.Logger -> Microseconds -> B.ByteString -> IO ()
-              -> Multiplex a -> IO a
-runStandardIO logger sleepAfter rem interrupt m = do
-  hSetBinaryMode stdin True
-  hSetBinaryMode stdout True
-  fresh <- uniqueChannel
-  output <- atomically Q.empty :: IO (Q.Queue (Maybe Packet))
-  input <- atomically newTQueue :: IO (TQueue (Maybe Packet))
-  cb0@(Callbacks cbm cba) <- Callbacks <$> atomically M.new <*> atomically (newTVar 0)
-  let env = (Q.enqueue output . (Just <$>), cb0, fresh, logger)
-  activity <- atomically $ newTVar 0
-  let bump = atomically $ modifyTVar' activity (1+)
-  _ <- Async.async $ do
-    interrupt
-    atomically $ writeTQueue input Nothing
-    L.info logger "interrupted"
-  _ <- Async.async $ do
-    let write pk _ = bump >> atomically (writeTQueue input (Just pk))
-    deserializeHandle stdin rem write
-    bump
-    atomically $ writeTQueue input Nothing
-    L.info logger "shutting down reader thread"
-  writer <- Async.async . repeatWhile $ do
-    logger <- pure $ L.scope "writer" logger
-    packet <- atomically $ Q.tryDequeue output :: IO (Maybe (Maybe Packet))
-    packet <- case packet of
-      -- writer is saturated, don't bother flushing output buffer
-      Just packet -> pure packet
-      -- writer not saturated; flush output buffer to avoid latency and/or deadlock
-      Nothing -> hFlush stdout >> atomically (Q.dequeue output)
-    B.putStr (Put.runPutS (serialize packet))
-    case packet of
-      Nothing -> False <$ L.info logger "writer shutting down"
-      Just packet -> do
-        L.debug logger $ "output packet " ++ show packet
-        True <$ bump
-  watchdog <- Async.async . repeatWhile $ do
-    activity0 <- (+) <$> readTVarIO activity <*> readTVarIO cba
-    C.threadDelay sleepAfter
-    activity1 <- (+) <$> readTVarIO activity <*> readTVarIO cba
-    nothingPending <- atomically $ M.null cbm
-    L.debug' (L.scope "watchdog" logger) $ do
-      keys <- fmap (map fst) . ListT.toList . Morph.hoist atomically . M.stream $ cbm
-      pure $ "current subscription keys: " ++ show (map Base64.encode keys)
-    L.debug (L.scope "watchdog" logger) $
-      "activity: " ++ show (activity0, activity1, nothingPending)
-    continue <- atomically $
-      if activity0 == activity1 && nothingPending then do
-        writeTQueue input Nothing
-        Q.enqueue output (pure Nothing)
-        pure False
-      else
-        pure True
-    when (not continue) $ L.info logger "watchdog shutting down"
-    pure continue
-  a <- run env m
-  processor <- Async.async $ do
-    run env (process $ atomically (readTQueue input))
-    L.info logger "processor shutting down"
-  Async.wait watchdog
-  -- Async.wait reader
-  Async.wait processor
-  Async.wait writer
-  L.info logger "Mux.runStandardIO shutdown"
-  pure a
-
-deserializeHandle :: Serial a => Handle -> B.ByteString -> (a -> Int -> IO ()) -> IO ()
-deserializeHandle h rem write = go (Get.runGetPartial deserialize rem) where
-  go dec = do
-    (a, n, rem') <- deserializeHandle1 h dec
-    write a (n + B.length rem)
-    go (Get.runGetPartial deserialize rem')
-
-deserializeHandle1' :: Serial a => Handle -> IO (a, Int, B.ByteString)
-deserializeHandle1' h = deserializeHandle1 h (Get.runGetPartial deserialize B.empty)
-
-deserializeHandle1 :: Handle -> Get.Result a -> IO (a, Int, B.ByteString)
-deserializeHandle1 h dec = go dec 0 where
-  go result !n = case result of
-    Get.Fail msg _ -> fail msg
-    Get.Partial k -> do
-      bs <- B.hGetSome h 65536
-      go (k bs) (n + B.length bs)
-    Get.Done a rem -> pure (a, n, rem)
-
 ask :: Multiplex Env
 ask = Multiplex Reader.ask
 
-bumpActivity :: Multiplex ()
-bumpActivity = do
-  (_, Callbacks _ cba, _, _) <- ask
-  liftIO $ bumpActivity' cba
-
-bumpActivity' :: TVar Word64 -> IO ()
-bumpActivity' cba = atomically $ modifyTVar' cba (1+)
-
 logger :: Multiplex L.Logger
 logger = do
-  ~(_, _, _, logger) <- ask
+  ~(_, _, _, _, logger) <- ask
   pure logger
 
 scope :: String -> Multiplex a -> Multiplex a
 scope msg = local tweak where
-  tweak (a,b,c,logger) = (a,b,c,L.scope msg logger)
+  tweak (a,b,c,d,logger) = (a,b,c,d,L.scope msg logger)
+
+-- | Crash with a message. Include the current logging scope.
+crash :: String -> Multiplex a
+crash msg = do
+  -- warn msg
+  scope msg $ do
+    l <- logger
+    fail (show $ L.getScope l)
 
 info, warn, debug :: String -> Multiplex ()
 info msg = logger >>= \logger -> liftIO $ L.info logger msg
@@ -181,7 +109,7 @@ debug msg = logger >>= \logger -> liftIO $ L.debug logger msg
 
 process :: IO (Maybe Packet) -> Multiplex ()
 process recv = scope "Mux.process" $ do
-  (_, Callbacks cbs cba, _, logger) <- ask
+  (_, Callbacks cbs _, _, _, logger) <- ask
   liftIO . repeatWhile $ do
     packet <- recv
     case packet of
@@ -190,11 +118,10 @@ process recv = scope "Mux.process" $ do
         callback <- atomically $ M.lookup destination cbs
         case callback of
           Nothing -> do
-            L.warn logger $ "dropped packet @ " ++ show (Base64.encode destination)
+            L.info logger $ "dropped packet @ " ++ show (Base64.encode destination)
             pure True
           Just callback -> do
             L.debug logger $ "packet delivered @ " ++ show (Base64.encode destination)
-            bumpActivity' cba
             callback content
             pure True
 
@@ -253,40 +180,41 @@ type Request a b = Channel (a, Channel b)
 type Microseconds = Int
 
 requestTimedVia' :: (Serial a, Serial b)
-                 => Microseconds
+                 => String
+                 -> Microseconds
                  -> (STM (a, Channel b) -> Multiplex ())
                  -> Channel b
                  -> STM a
                  -> Multiplex (Multiplex b)
-requestTimedVia' micros send replyTo a = do
+requestTimedVia' msg micros send replyTo a = do
   env <- ask
   (receive, cancel) <- receiveCancellable replyTo
   send $ (,replyTo) <$> a
   watchdog <- liftIO . C.forkIO $ do
     liftIO $ C.threadDelay micros
-    run env cancel
+    run env (cancel $ "requestTimedVia timeout " ++ msg)
   pure $ receive <* liftIO (C.killThread watchdog)
 
-requestTimedVia :: (Serial a, Serial b) => Microseconds -> Request a b -> Channel b -> STM a
+requestTimedVia :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> Channel b -> STM a
                 -> Multiplex (Multiplex b)
-requestTimedVia micros req replyTo a =
+requestTimedVia msg micros req replyTo a =
-  requestTimedVia' micros (send' req) replyTo a
+  requestTimedVia' msg micros (send' req) replyTo a
 
-requestTimed' :: (Serial a, Serial b) => Microseconds -> Request a b -> STM a -> Multiplex (Multiplex b)
+requestTimed' :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> STM a -> Multiplex (Multiplex b)
-requestTimed' micros req a = do
+requestTimed' msg micros req a = do
   replyTo <- channel
-  requestTimedVia micros req replyTo a
+  requestTimedVia msg micros req replyTo a
 
-requestTimed :: (Serial a, Serial b) => Microseconds -> Request a b -> a -> Multiplex (Multiplex b)
+requestTimed :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> a -> Multiplex (Multiplex b)
-requestTimed micros req a = do
+requestTimed msg micros req a = do
   replyTo <- channel
   env <- ask
   (receive, cancel) <- receiveCancellable replyTo
   send req (a, replyTo)
   watchdog <- liftIO . C.forkIO $ do
     liftIO $ C.threadDelay micros
-    run env cancel
+    run env (cancel $ "requestTimed timeout " ++ msg)
-  pure $ receive <* liftIO (C.killThread watchdog) <* cancel
+  pure $ receive <* liftIO (C.killThread watchdog) <* cancel ("requestTimed completed")
 
 type Cleartext = B.ByteString
 type Ciphertext = B.ByteString
@@ -294,18 +222,19 @@ type CipherState = (Cleartext -> STM Ciphertext, Ciphertext -> STM Cleartext)
 
 encryptedRequestTimedVia
   :: (Serial a, Serial b)
-  => CipherState
+  => String
+  -> CipherState
   -> Microseconds
   -> ((a,Channel b) -> Multiplex ())
   -> Channel b
   -> a
   -> Multiplex b
-encryptedRequestTimedVia (_,decrypt) micros send replyTo@(Channel _ bs) a = do
+encryptedRequestTimedVia msg (_,decrypt) micros send replyTo@(Channel _ bs) a = do
-  responseCiphertext <- receiveTimed micros (Channel Type bs)
+  responseCiphertext <- receiveTimed msg micros (Channel Type bs)
   send (a, replyTo)
   responseCiphertext <- responseCiphertext -- force the receive
   responseCleartext <- liftIO . atomically . decrypt $ responseCiphertext
-  either fail pure $ Get.runGetS deserialize responseCleartext
+  either crash pure $ Get.runGetS deserialize responseCleartext
 
 encryptAndSendTo
   :: (Serial a, Serial node)
@@ -329,13 +258,13 @@ fork m = do
 
 nest :: Serial k => k -> Multiplex a -> Multiplex a
 nest outer m = Reader.local tweak m where
-  tweak (send,cbs,fresh,log) = (send' send,cbs,fresh,log)
+  tweak (send,cbs,fresh,recvs,log) = (send' send,cbs,fresh,recvs,log)
   kbytes = Put.runPutS (serialize outer)
   send' send p = send $ (\p -> Packet kbytes (Put.runPutS (serialize p))) <$> p
 
 channel :: Multiplex (Channel a)
 channel = do
-  ~(_,_,fresh,_) <- ask
+  ~(_,_,fresh,_,_) <- ask
   Channel Type <$> liftIO fresh
 
 send :: Serial a => Channel a -> a -> Multiplex ()
@@ -343,32 +272,66 @@ send chan a = send' chan (pure a)
 
 send' :: Serial a => Channel a -> STM a -> Multiplex ()
 send' (Channel _ key) a = do
-  ~(send,_,_,_) <- ask
+  ~(send,_,_,_,_) <- ask
   liftIO . atomically $ send (Packet key . Put.runPutS . serialize <$> a)
 
-receiveCancellable :: Serial a => Channel a -> Multiplex (Multiplex a, Multiplex ())
+receiveCancellable' :: Channel a
-receiveCancellable (Channel _ key) = do
+                    -> Multiplex (Multiplex B.ByteString, String -> Multiplex ())
-  (_,Callbacks cbs cba,_,_) <- ask
+receiveCancellable' chan@(Channel _ key) = do
+  (_,Callbacks cbs _,_,_,_) <- ask
   result <- liftIO newEmptyMVar
-  liftIO . atomically $ M.insert (putMVar result . Right) key cbs
+  liftIO . atomically $ M.insert (void . tryPutMVar result . Right) key cbs
-  liftIO $ bumpActivity' cba
+  cancel <- pure $ \reason -> do
-  cancel <- pure $ do
     liftIO . atomically $ M.delete key cbs
-    liftIO $ putMVar result (Left "cancelled")
+    liftIO . void $ tryPutMVar result (Left $ "Mux.cancelled: " ++ reason)
-  force <- pure . liftIO $ do
+  force <- pure . scope (show chan) . scope "receiveCancellable" $ do
-    bytes <- takeMVar result
+    info "awaiting result"
-    bytes <- either fail pure bytes
+    bytes <- liftIO $ takeMVar result
-    either fail pure $ Get.runGetS deserialize bytes
+    info "got result"
+    bytes <- either crash pure bytes
+    info "got result bytes"
+    pure bytes
   pure (force, cancel)
 
-receiveTimed :: Serial a => Microseconds -> Channel a -> Multiplex (Multiplex a)
+receiveCancellable :: Serial a => Channel a -> Multiplex (Multiplex a, String -> Multiplex ())
-receiveTimed micros chan = do
+receiveCancellable chan@(Channel _ key) = f <$> receiveCancellable' chan where
-  (force, cancel) <- receiveCancellable chan
+  f (get, cancel) = (g =<< get, cancel)
+  g bytes = either crash pure $ Get.runGetS deserialize bytes
+
+receiveTimed' :: String -> Microseconds -> Channel a -> Multiplex (Multiplex B.ByteString)
+receiveTimed' msg micros chan = do
+  (force, cancel) <- receiveCancellable' chan
   env <- ask
   watchdog <- liftIO . C.forkIO $ do
     liftIO $ C.threadDelay micros
-    run env cancel
+    run env (cancel $ "receiveTimed timeout during " ++ msg)
-  pure $ force <* liftIO (C.killThread watchdog) <* cancel
+  pure $ scope "receiveTimed" (force <* liftIO (C.killThread watchdog) <* cancel ("receiveTimed completed" ++ msg))
+
+receiveTimed :: Serial a => String -> Microseconds -> Channel a -> Multiplex (Multiplex a)
+receiveTimed msg micros chan = tweak <$> receiveTimed' msg micros chan where
+  tweak bytes = tweak' =<< bytes
+  tweak' bytes = either crash pure $ Get.runGetS deserialize bytes
+
+-- Save a receive future as part of
+saveReceive :: Microseconds
+            -> B.ByteString -> Multiplex B.ByteString -> Multiplex ()
+saveReceive micros chan force = do
+  (_,_,_,recvs,_) <- ask
+  tid <- liftIO . C.forkIO $ do
+    C.threadDelay micros
+    atomically $ M.delete chan recvs
+  let force' = do
+        liftIO $ C.killThread tid
+        liftIO $ atomically (M.delete chan recvs)
+        force
+  liftIO . atomically $ M.insert force' chan recvs
+
+restoreReceive :: B.ByteString -> Multiplex B.ByteString
+restoreReceive chan = do
+  (_,_,_,recvs,_) <- ask
+  o <- liftIO . atomically $ M.lookup chan recvs
+  fromMaybe (crash $ "chan could not be restored: " ++ show (Base64.encode chan))
+            o
 
 timeout' :: Microseconds -> a -> Multiplex a -> Multiplex a
 timeout' micros onTimeout m = fromMaybe onTimeout <$> timeout micros m
@@ -413,15 +376,14 @@ subscribeTimed micros chan = do
         loop logger activity result cancel
 
 subscribe :: Serial a => Channel a -> Multiplex (Multiplex a, Multiplex ())
-subscribe (Channel _ key) = do
+subscribe (Channel _ key) = scope "subscribe" $ do
-  (_, Callbacks cbs cba, _, _) <- ask
+  (_, Callbacks cbs _, _, _, _) <- ask
   q <- liftIO . atomically $ newTQueue
   liftIO . atomically $ M.insert (atomically . writeTQueue q) key cbs
-  liftIO $ bumpActivity' cba
   unsubscribe <- pure . liftIO . atomically . M.delete key $ cbs
-  force <- pure . liftIO $ do
+  force <- pure $ do
-    bytes <- atomically $ readTQueue q
+    bytes <- liftIO . atomically $ readTQueue q
-    either fail pure $ Get.runGetS deserialize bytes
+    either crash pure $ Get.runGetS deserialize bytes
   pure (force, unsubscribe)
 
 seconds :: Microseconds -> Int
@@ -487,7 +449,7 @@ pipeInitiate crypto rootChan (recipient,recipientKey) u = scope "pipeInitiate" $
           bytes <- fetchh
           debug "... handshake round trip completed"
           case bytes of
-            Nothing -> cancelh >> cancelc >> fail "cancelled handshake"
+            Nothing -> cancelh >> cancelc >> crash "cancelled handshake"
             Just bytes -> liftIO (atomically $ decrypt bytes) >> go
 
 -- todo: add access control here, better to bail ASAP (or after 1s delay
@@ -505,7 +467,7 @@ pipeRespond crypto allow _ extractSender payload = do
   (doneHandshake, senderKey, encrypt, decrypt) <- liftIO $ C.pipeResponder crypto
   debug $ "decrypting initial payload"
   bytes <- (liftLogged "[Mux.pipeRespond] decrypt" . atomically . decrypt) payload
-  (u, chans@(handshakeChan,connectedChan)) <- either fail pure $ Get.runGetS deserialize bytes
+  (u, chans@(handshakeChan,connectedChan)) <- either crash pure $ Get.runGetS deserialize bytes
   debug $ "handshake channels: " ++ show chans
   let sender = extractSender u
   handshakeSub <- subscribeTimed handshakeTimeout handshakeChan
@@ -531,7 +493,7 @@ pipeRespond crypto allow _ extractSender payload = do
         Nothing -> pure ()
         Just senderKey -> allow senderKey >>= \ok ->
           if ok then pure ()
-          else liftIO (C.threadDelay delayBeforeFailure) >> fail "disallowed key"
+          else liftIO (C.threadDelay delayBeforeFailure) >> crash "disallowed key"
     go = do
       ready <- liftIO $ atomically doneHandshake
       checkSenderKey
@@ -545,5 +507,5 @@ pipeRespond crypto allow _ extractSender payload = do
           nest sender $ send' chanh (encrypt B.empty)
           bytes <- fetchh
           case bytes of
-            Nothing -> cancelh >> cancelc >> fail "cancelled handshake"
+            Nothing -> cancelh >> cancelc >> crash "cancelled handshake"
             Just bytes -> liftIO (atomically $ decrypt bytes) >> go

node/src/Unison/Runtime/Remote.hs

@@ -4,6 +4,7 @@
 
 module Unison.Runtime.Remote where
 
+import Control.Concurrent.Async (Async)
 import Data.Functor
 import Data.Maybe
 import Control.Monad
@@ -107,10 +108,10 @@ server :: (Ord h, Serial key, Serial t, Show t, Serial h)
        -> Env t h
        -> Language t h
        -> P.Protocol t hash h' h
-       -> Multiplex ()
+       -> Multiplex (Async ())
 server crypto allow env lang p = do
   (accept,_) <- Mux.subscribeTimed (Mux.seconds 60) (Mux.erase (P._eval p))
-  void . Mux.fork . Mux.repeatWhile $ do
+  Mux.fork . Mux.repeatWhile $ do
     initialPayload <- accept
     case initialPayload of
       Nothing -> pure False
@@ -120,7 +121,7 @@ server crypto allow env lang p = do
         -- guard $ Put.runPutS (serialize peerKey) == publicKey peer
         Mux.scope "Remote.server" . Mux.repeatWhile $ do
           r <- recv
-          Mux.info $ "eval " ++ show r
+          Mux.debug $ "eval " ++ show r
           case r of
             Nothing -> pure False
             Just (r, ackChan) -> do
@@ -132,7 +133,8 @@ server crypto allow env lang p = do
               where
               fetch hs = do
                 syncChan <- Mux.channel
-                Mux.encryptedRequestTimedVia cipherstate (Mux.seconds 5) (send . Just . Just) syncChan (Set.toList hs)
+                Mux.encryptedRequestTimedVia "fetching hashes"
+                  cipherstate (Mux.seconds 5) (send . Just . Just) syncChan (Set.toList hs)
               loop needs | Set.null needs = pure ()
               loop needs = fetch needs >>= \hashes -> case hashes of
                 Nothing -> fail "expected hashes, got timeout"
@@ -175,8 +177,8 @@ handle crypto allow env lang p r = Mux.debug (show r) >> case r of
          client crypto allow env p n r
          Mux.debug $ "transferred to node: " ++ show n
   runLocal (Fork r) = do
-    Mux.debug $ "runLocal Fork"
+    Mux.info $ "runLocal Fork"
-    Mux.fork (handle crypto allow env lang p r) $> unit lang
+    unit lang <$ Mux.fork (handle crypto allow env lang p r)
   runLocal CreateChannel = do
     Mux.debug $ "runLocal CreateChannel"
     channel lang . Channel . Mux.channelId <$> Mux.channel
@@ -185,25 +187,36 @@ handle crypto allow env lang p r = Mux.debug (show r) >> case r of
     pure $ node lang (currentNode env)
   runLocal Spawn = do
     Mux.debug $ "runLocal Spawn"
-    n <- Mux.requestTimed (Mux.seconds 5) (P._spawn p) B.empty
+    n <- Mux.requestTimed "runLocal.spawn" (Mux.seconds 5) (P._spawn p) B.empty
     n <- n
     Mux.debug $ "runLocal Spawn completed: " ++ show n
     pure (node lang n)
   runLocal (Pure t) = do
     Mux.debug $ "runLocal Pure"
     liftIO $ eval lang t
-  runLocal (Send (Channel cid) a) = do
+  runLocal (Send c@(Channel cid) a) = do
-    Mux.debug $ "runLocal Send " ++ show cid
+    Mux.debug $ "runLocal Send " ++ show c ++ " " ++ show a
+    a <- liftIO $ eval lang a
+    Mux.debug $ "runLocal Send[2] " ++ show c ++ " " ++ show a
     Mux.process1 (Mux.Packet cid (Put.runPutS (serialize a)))
     pure (unit lang)
+  runLocal (Sleep (Seconds seconds)) = do
+    let micros = floor $ seconds * 1000 * 1000
+    liftIO $ C.threadDelay micros
+    pure (unit lang)
   runLocal (ReceiveAsync chan@(Channel cid) (Seconds seconds)) = do
-    Mux.debug $ "runLocal ReceiveAsync " ++ show (seconds, cid)
+    Mux.debug $ "runLocal ReceiveAsync " ++ show (seconds, chan)
-    _ <- Mux.receiveTimed (floor $ seconds * 1000 * 1000) ((Mux.Channel Mux.Type cid) :: Mux.Channel (Maybe B.ByteString))
+    forceChan <- Mux.channel
-    pure (remote lang (Step (Local (Receive chan))))
+    Mux.debug $ "ReceiveAsync force channel " ++ show forceChan
-  runLocal (Receive (Channel cid)) = do
+    let micros = floor $ seconds * 1000 * 1000
-    Mux.debug $ "runLocal Receive " ++ show cid
+    force <- Mux.receiveTimed' ("receiveAsync on " ++ show chan)
-    (recv,_) <- Mux.receiveCancellable (Mux.Channel Mux.Type cid)
+      micros ((Mux.Channel Mux.Type cid) :: Mux.Channel B.ByteString)
-    bytes <- recv
+    Mux.saveReceive micros (Mux.channelId forceChan) force
+    pure (remote lang (Step (Local (Receive (Channel $ Mux.channelId forceChan)))))
+  runLocal (Receive chan@(Channel cid)) = do
+    Mux.debug $ "runLocal Receive " ++ show chan
+    bytes <- Mux.restoreReceive cid
+    Mux.debug $ "runLocal Receive got bytes " ++ show chan
     case Get.runGetS deserialize bytes of
       Left err -> fail err
       Right r -> pure r
@@ -233,7 +246,7 @@ client crypto allow env p recipient r = Mux.scope "Remote.client" $ do
   Mux.info $ "connected"
   replyChan <- Mux.channel
   let send' (a,b) = send (Just (a,b))
-  _ <- Mux.encryptedRequestTimedVia cipherstate (Mux.seconds 5) send' replyChan r
+  _ <- Mux.encryptedRequestTimedVia "client ack" cipherstate (Mux.seconds 5) send' replyChan r
   Mux.debug $ "got ack on " ++ show replyChan
   -- todo - might want to retry if ack doesn't come back
   id $

node/src/Worker.hs

@@ -1,56 +0,0 @@
-{-# Language OverloadedStrings #-}
-
-module Main where
-
-import Control.Monad
-import Unison.Hash (Hash)
-import Unison.NodeProtocol.V0 (protocol)
-import Unison.NodeWorker as W
-import Unison.SerializationAndHashing (TermV)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Unison.Cryptography as C
-import qualified Unison.Eval as Eval
-import qualified Unison.Eval.Interpreter as I
-import qualified Unison.Node.Builtin as Builtin
-import qualified Unison.Note as Note
-import qualified Unison.Remote as RT
-import qualified Unison.Runtime.ExtraBuiltins as ExtraBuiltins
-import qualified Unison.Runtime.Remote as R
-import qualified Unison.Term as Term
-import qualified Unison.Typechecker as Typechecker
-
-main :: IO ()
-main = W.make protocol crypto (pure lang) where
-  crypto keypair = C.noop (W.public keypair)
-  lang crypto blockstore = do
-    let b0 = Builtin.makeBuiltins
-    b1 <- ExtraBuiltins.makeAPI blockstore crypto
-    pure $ go b0 b1
-    where
-      go b0 b1 = (lang, typecheck) where
-        lang :: R.Language TermV Hash
-        lang = R.Language localDependencies eval apply node unit channel local unRemote remote
-        codestore = R.makeCodestore blockstore :: R.Codestore TermV Hash
-        localDependencies _ = Set.empty -- todo, compute this for real
-        evaluator = I.eval allprimops
-        whnf = Eval.whnf evaluator gethash
-        allbuiltins = b0 whnf ++ b1 whnf
-        allprimops = Map.fromList [ (r, op) | Builtin.Builtin r (Just op) _ _ <- allbuiltins ]
-        gethash h = Note.lift $ do
-          [(h',t)] <- R.getHashes codestore (Set.singleton h)
-          guard $ h == h'
-          pure t
-        typeEnv ref = case lookup ref [ (r, t) | Builtin.Builtin r _ t _ <- allbuiltins ] of
-          Nothing -> fail $ "unknown reference " ++ show ref
-          Just t -> pure t
-        eval t = Note.run (whnf t)
-        typecheck term = Note.attemptRun . void $ Typechecker.synthesize typeEnv term
-      apply = Term.app
-      node = Term.node
-      unit = Term.builtin "()"
-      channel = Term.channel
-      local l = Term.remote (RT.Step (RT.Local l))
-      unRemote (Term.Distributed' (Term.Remote r)) = Just r
-      unRemote _ = Nothing
-      remote = Term.remote

node/tests/Unison/Test/Html.hs

@@ -33,19 +33,26 @@ numlinks = let found = getLinks $ pack testHTML in if 3 == length found
   then pure ()
   else fail $ "expected 3 links, got " ++ show found
 
+plainText :: Assertion
+plainText = let expected = "simple linkInside one Inside other outside one  inside list  Empty link"
+                result = toPlainText $ pack testHTML
+            in if expected == result
+               then pure ()
+               else fail $ "got unclean html: " ++ show result
+
 tests :: TestTree
 tests = testGroup "html"
   [ testCase "numlinks" numlinks
   ]
 
 -- evaluateTerms :: [(Path, e)] -> Noted m [(Path,e,e)],
-unisonEvaluate :: TestNode -> Assertion
+unisonEvaluate :: (TestNode, String -> TermV) -> Assertion
-unisonEvaluate testNode = do
+unisonEvaluate (testNode, parse) = do
   let inputPath = [P.Fn]
-      getLinksTerm = unsafeParseTerm $ "getLinks \"" ++ testHTML2 ++ "\""
+      getLinksTerm = parse $ "Html.get-links \"" ++ testHTML2 ++ "\""
       linkTerm = EB.link (Term.text "link.html") (Term.text "description")
-      getLink = Term.ref (R.Builtin "Html.getHref") `Term.app` linkTerm
+      getLink = Term.ref (R.Builtin "Html.get-href") `Term.app` linkTerm
-      getDescription = Term.ref (R.Builtin "Html.getDescription") `Term.app` linkTerm
+      getDescription = Term.ref (R.Builtin "Html.get-description") `Term.app` linkTerm
       desiredLinks = Term.vector [linkTerm]
       desiredHref = Term.text "link.html"
       desiredDescription = Term.text "description"
@@ -64,8 +71,14 @@ unisonEvaluate testNode = do
         , "description match ", show (description == desiredDescription)
         ]
 
-nodeTests :: TestNode -> TestTree
+nodeTests :: (TestNode, String -> TermV) -> TestTree
 nodeTests testNode = testGroup "html"
   [ testCase "numlinks" numlinks
+  , testCase "plainText" plainText
   , testCase "unisonEvaluate" (unisonEvaluate testNode)
   ]
+
+main :: IO ()
+main = do
+  testNode <- makeTestNode
+  defaultMain (nodeTests testNode)

node/tests/Unison/Test/NodeUtil.hs

@@ -2,6 +2,8 @@
 
 module Unison.Test.NodeUtil where
 
+import Control.Applicative
+import Data.Text.Encoding (decodeUtf8)
 import Unison.Hash (Hash)
 import Unison.Node (Node)
 import Unison.Reference (Reference)
@@ -10,21 +12,31 @@ import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Var (Var)
+import qualified Data.ByteString as B
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text.IO
+import qualified System.FilePath as FP
 import qualified Unison.ABT as ABT
 import qualified Unison.BlockStore.MemBlockStore as MBS
 import qualified Unison.Cryptography as C
 import qualified Unison.Hash as Hash
+import qualified Unison.Node as Node
 import qualified Unison.Node.BasicNode as BasicNode
 import qualified Unison.Node.Builtin as Builtin
+import qualified Unison.Node.FileStore as FS
 import qualified Unison.Node.UnisonBlockStore as UBS
+import qualified Unison.Note as Note
+import qualified Unison.Parsers as Parsers
 import qualified Unison.Reference as R
 import qualified Unison.Reference as Reference
 import qualified Unison.Runtime.ExtraBuiltins as EB
 import qualified Unison.Term as Term
 import qualified Unison.View as View
+import qualified Unison.Util.Logger as L
 
 type DFO = View.DFO
 type V = Symbol DFO
+type TermV = Term V
 type TestNode = Node IO V R.Reference (Type V) (Term V)
 
 hash :: Var v => Term.Term v -> Reference
@@ -34,11 +46,32 @@ hash t = Reference.Derived (ABT.hash t)
 makeRandomAddress :: C.Cryptography k syk sk skp s h c -> IO Address
 makeRandomAddress crypt = Address <$> C.randomBytes crypt 64
 
-makeTestNode :: IO TestNode
+loadDeclarations :: L.Logger -> FilePath -> Node IO V Reference (Type V) (Term V) -> IO ()
+loadDeclarations logger path node = do
+  -- note - when run from repl current directory is root, but when run via stack test, current
+  -- directory is the shared subdir - so we check both locations
+  txt <- decodeUtf8 <$> (B.readFile path <|> B.readFile (".." `FP.combine` path))
+  let str = Text.unpack txt
+  _ <- Note.run $ Node.declare' Term.ref str node
+  L.info logger $ "loaded file: " ++ path
+
+makeTestNode :: IO (TestNode, String -> Term V)
 makeTestNode = do
+  logger <- L.atomic (L.atInfo L.toStandardOut)
   let crypto = C.noop "dummypublickey"
+  putStrLn "creating block store..."
   blockStore <- MBS.make' (makeRandomAddress crypto) makeAddress
+  putStrLn "created block store, creating Node store..."
   store' <- UBS.make blockStore
-  keyValueOps <- EB.makeAPI blockStore crypto
+  -- store' <- FS.make "blockstore.file"
-  let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
+  putStrLn "created Node store..., building extra builtins"
-  BasicNode.make hash store' makeBuiltins
+  extraBuiltins <- EB.make logger blockStore crypto
+  putStrLn "extra builtins created"
+  let makeBuiltins whnf = concat [Builtin.makeBuiltins logger whnf, extraBuiltins whnf]
+  node <- BasicNode.make hash store' makeBuiltins
+  L.info logger "Node created"
+  loadDeclarations logger "unison-src/base.u" node
+  loadDeclarations logger "unison-src/extra.u" node
+  builtins <- Note.run $ Node.allTermsByVarName Term.ref node
+  let parse = Parsers.bindBuiltins builtins [] . Parsers.unsafeParseTerm
+  pure (node, parse)

node/tests/Unison/Test/SerializationAndHashing.hs

@@ -26,10 +26,10 @@ lambda :: Assertion
 lambda = testTermString "x -> x"
 
 letBinding :: Assertion
-letBinding = testTermString "let x = 42 in x + 1"
+letBinding = testTermString "let x = 42; x + 1;;"
 
 letRec :: Assertion
-letRec = testTermString "let rec x = x + 1 in x"
+letRec = testTermString "let rec x = x + 1; x;;"
 
 vec :: Assertion
 vec = testTermString "[\"a\", \"b\", \"c\"]"
@@ -43,5 +43,4 @@ tests = testGroup "SerializationAndHashing"
   , testCase "letBinding" letBinding
   , testCase "letRec" letRec
   , testCase "vec" vec
-
   ]

node/tests/pingpong.u

@@ -1,14 +0,0 @@
--- run from unison root directory
--- curl -H "Content-Type: text/plain; charset=UTF-8" --data-binary @node/tests/pingpong.u http://localhost:8081/compute/dummynode909
-
-Remote {
-  n1 := Remote.spawn;
-  n2 := Remote.spawn;
-  let rec
-    ping i = Remote { 
-      i := Remote.at n2 (i + 1); 
-      if (i >= 5) (pure i) (pong i); 
-    };
-    pong i = Remote { i := Remote.at n1 (i + 1); ping i; }
-  in ping 0;
-}

node/unison-node.cabal

@@ -50,10 +50,10 @@ library
     Unison.Hash.Extra
     Unison.Kind.Extra
     Unison.Metadata.Extra
+    Unison.Node.FileStore
     Unison.Node.UnisonBlockStore
     Unison.NodeContainer
     Unison.NodeServer
-    Unison.NodeWorker
     Unison.NodeProtocol
     Unison.NodeProtocol.V0
     Unison.Reference.Extra
@@ -110,7 +110,7 @@ library
     directory,
     filepath,
     free,
-    hashable, 
+    hashable,
     http-types,
     io-streams,
     list-t,
@@ -119,6 +119,7 @@ library
     mtl,
     murmur-hash,
     network,
+    network-uri,
     network-simple,
     prelude-extras,
     process,
@@ -149,47 +150,10 @@ library
 
   if flag(leveldb)
     build-depends: exceptions, leveldb-haskell
+    cpp-options: -Dleveldb
     exposed-modules:
                     Unison.BlockStore.LevelDbStore
 
-executable worker
-  main-is: Worker.hs
-  hs-source-dirs: src
-  ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N -v0
-
-  if flag(optimized)
-    ghc-options: -funbox-strict-fields -O2
-
-  build-depends:
-    async,
-    base,
-    base64-bytestring,
-    bytes,
-    bytestring,
-    cereal,
-    containers,
-    configurator,
-    cryptonite,
-    curl,
-    free,
-    hashable,
-    list-t,
-    memory,
-    mmorph,
-    mtl,
-    stm,
-    stm-containers,
-    tagsoup,
-    text,
-    time,
-    transformers,
-    unison-node,
-    unison-shared,
-    vector
-
-  if flag(leveldb)
-    build-depends: exceptions, leveldb-haskell
-
 executable container
   main-is: Container.hs
   hs-source-dirs: src
@@ -222,11 +186,13 @@ executable container
     memory,
     mmorph,
     mtl,
+    network-uri,
     process,
     safecopy,
     scotty,
     stm,
     stm-containers,
+    tagsoup,
     text,
     time,
     transformers,
@@ -237,8 +203,35 @@ executable container
     wai-extra,
     wai-middleware-static
 
+  other-modules:
+    Unison.ABT.Extra,
+    Unison.BlockStore.FileBlockStore,
+    Unison.Config,
+    Unison.Distance.Extra,
+    Unison.Hash.Extra,
+    Unison.Kind.Extra,
+    Unison.NodeContainer,
+    Unison.NodeProtocol,
+    Unison.NodeProtocol.V0,
+    Unison.NodeServer,
+    Unison.NodeWorker,
+    Unison.Reference.Extra,
+    Unison.Remote.Extra,
+    Unison.Runtime.Block,
+    Unison.Runtime.ExpiringMap,
+    Unison.Runtime.Lock,
+    Unison.Runtime.Multiplex,
+    Unison.Runtime.Queue,
+    Unison.Runtime.Remote,
+    Unison.Runtime.SharedResourceMap,
+    Unison.SerializationAndHashing,
+    Unison.Symbol.Extra,
+    Unison.Term.Extra,
+    Unison.Type.Extra
+
   if flag(leveldb)
     build-depends: exceptions, leveldb-haskell
+    cpp-options: -Dleveldb
 
 executable node
   main-is: Node.hs
@@ -273,6 +266,7 @@ executable node
     memory,
     mtl,
     murmur-hash,
+    network-uri,
     prelude-extras,
     random,
     safecopy,
@@ -288,6 +282,29 @@ executable node
     vector,
     wai-extra,
     wai-middleware-static
+  other-modules:
+    Unison.ABT.Extra,
+    Unison.BlockStore.FileBlockStore,
+    Unison.Distance.Extra,
+    Unison.Hash.Extra,
+    Unison.Kind.Extra,
+    Unison.Node.FileStore,
+    Unison.NodeServer,
+    Unison.Reference.Extra,
+    Unison.Remote.Extra,
+    Unison.Runtime.Address,
+    Unison.Runtime.Block,
+    Unison.Runtime.ExtraBuiltins,
+    Unison.Runtime.Html,
+    Unison.Runtime.Http,
+    Unison.Runtime.Index,
+    Unison.Runtime.Journal,
+    Unison.Runtime.JournaledMap,
+    Unison.Runtime.ResourcePool,
+    Unison.SerializationAndHashing,
+    Unison.Symbol.Extra,
+    Unison.Term.Extra,
+    Unison.Type.Extra
 
   if flag(leveldb)
     build-depends: exceptions, leveldb-haskell
@@ -308,6 +325,7 @@ test-suite tests
     ctrie,
     curl,
     directory,
+    filepath,
     hashable,
     random,
     stm,
@@ -321,6 +339,16 @@ test-suite tests
     unison-node,
     unison-shared,
     vector
+  other-modules:
+    Unison.Test.BlockStore,
+    Unison.Test.BlockStore.FileBlockStore,
+    Unison.Test.BlockStore.MemBlockStore,
+    Unison.Test.Html,
+    Unison.Test.Index,
+    Unison.Test.Journal,
+    Unison.Test.NodeUtil,
+    Unison.Test.ResourcePool,
+    Unison.Test.SerializationAndHashing
 
   if flag(leveldb)
     build-depends: exceptions, leveldb-haskell

shared/src/Unison/ABT.hs

@@ -222,14 +222,24 @@ freshNamed' used n = fresh' used (v' n)
 -- | `subst v e body` substitutes `e` for `v` in `body`, avoiding capture by
 -- renaming abstractions in `body`
 subst :: (Foldable f, Functor f, Var v) => v -> Term f v a -> Term f v a -> Term f v a
-subst v = replace match where
+subst v r t2@(Term fvs ann body)
-  match (Var' v') = v == v'
+  | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped
-  match _ = False
+  | otherwise = case body of
+    Var v' | v == v' -> r    -- var match; perform replacement
+           | otherwise -> t2 -- var did not match one being substituted; ignore
+    Cycle body -> cycle' ann (subst v r body)
+    Abs x e | x == v -> t2 -- x shadows v; ignore subtree
+    Abs x e -> abs' ann x' e'
+      where x' = freshInBoth r t2 x
+            -- rename x to something that cannot be captured by `r`
+            e' = if x /= x' then subst v r (rename x x' e)
+                 else subst v r e
+    Tm body -> tm' ann (fmap (subst v r) body)
 
 -- | `substs [(t1,v1), (t2,v2), ...] body` performs multiple simultaneous
 -- substitutions, avoiding capture
 substs :: (Foldable f, Functor f, Var v) => [(v, Term f v a)] -> Term f v a -> Term f v a
-substs replacements body = foldr f body replacements where
+substs replacements body = foldr f body (reverse replacements) where
   f (v, t) body = subst v t body
 
 -- | `replace f t body` substitutes `t` for all maximal (outermost)

shared/src/Unison/Eval/Interpreter.hs

@@ -1,14 +1,18 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
+
 -- | Very simple and inefficient interpreter of Unison terms
 module Unison.Eval.Interpreter where
 
 import Data.Map (Map)
+import Data.List
 import Debug.Trace
 import Unison.Eval
 import Unison.Term (Term)
 import Unison.Var (Var)
 import qualified Data.Map as M
+import qualified Data.Text as Text
 import qualified Unison.ABT as ABT
 import qualified Unison.Reference as R
 import qualified Unison.Term as E
@@ -25,34 +29,49 @@ eval :: forall f v . (Monad f, Var v) => Map R.Reference (Primop f v) -> Eval f
 eval env = Eval whnf step
   where
     -- reduce x args | trace ("reduce:" ++ show (x:args)) False = undefined
-    reduce :: Term v -> [Term v] -> f (Maybe (Term v))
+    reduce resolveRef (E.Ann' e _) args = reduce resolveRef e args
-    reduce (E.Lam' _) [] = pure Nothing
+    reduce resolveRef (E.App' f x) args = do
-    reduce (E.Lam' f) (arg1:args) =
+      x <- whnf resolveRef x
-      let r = ABT.bind f arg1
+      reduce resolveRef f (x:args)
-      in pure $ Just (foldl E.app r args)
+    reduce resolveRef (E.Let1' binding body) xs = do
-    reduce (E.Ref' h) args = case M.lookup h env of
+      binding <- whnf resolveRef binding
-      Nothing -> pure Nothing
+      reduce resolveRef (ABT.bind body binding) xs
-      Just op | length args >= arity op ->
+    reduce resolveRef f args = do
-        call op (take (arity op) args) >>= \e ->
+      f <- whnf resolveRef f
-          pure . Just $ foldl E.app e (drop (arity op) args)
+      case f of
-      Just _ | otherwise -> pure Nothing
+        E.If' -> case take 3 args of
-    reduce (E.App' f x) args = reduce f (x:args)
+          [cond,t,f] -> do
-    reduce (E.Let1' binding body) xs = reduce (ABT.bind body binding) xs
+            cond <- whnf resolveRef cond
-    reduce _ _ = pure Nothing
+            case cond of
+              E.Builtin' c | Text.head c == 'F' -> pure . Just $ foldl E.app f (drop 3 args)
+                           | otherwise -> pure . Just $ foldl E.app t (drop 3 args)
+              _ -> pure Nothing
+          _ -> pure Nothing
+        E.Ref' h -> case M.lookup h env of
+          Nothing -> case h of
+            R.Derived h -> do
+              r <- resolveRef h
+              r <- whnf resolveRef r
+              reduce resolveRef r args
+            R.Builtin b -> pure Nothing
+          Just op | length args >= arity op ->
+            call op (take (arity op) args) >>= \e ->
+              pure . Just $ foldl E.app e (drop (arity op) args)
+          Just _ | otherwise -> pure Nothing
+        E.LamsNamed' vs body -> let n = length vs in case args of
+          [] -> pure Nothing
+          args | length args >= n -> pure $ Just (foldl' E.app (ABT.substs (vs `zip` args) body) (drop n args))
+               | otherwise -> pure Nothing
+        _ -> pure Nothing
 
     step resolveRef e = case e of
+      E.Ann' e _ -> step resolveRef e
       E.Ref' h -> case M.lookup h env of
         Just op | arity op == 0 -> call op []
         _ -> pure e
-      E.App' (E.LetRecNamed' bs body) x -> step resolveRef (E.letRec bs (body `E.app` x))
+      E.Apps' f xs -> do
-      E.App' f x -> do
+        e' <- reduce resolveRef f xs
-        f' <- E.link resolveRef f
-        e' <- reduce f' [x]
         maybe (pure e) pure e'
-      E.Ref' h -> do
-        f <- E.link resolveRef (E.ref h)
-        e <- reduce f []
-        maybe (pure f) pure e
       E.Let1' binding body -> step resolveRef (ABT.bind body binding)
       E.LetRecNamed' bs body -> step resolveRef (ABT.substs substs body) where
         expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
@@ -64,19 +83,30 @@ eval env = Eval whnf step
     whnf resolveRef e = case e of
       E.Ref' h -> case M.lookup h env of
         Just op | arity op == 0 -> call op []
-        _ -> pure e
+                | otherwise -> pure e
+        Nothing -> case h of
+          R.Derived h -> do
+            r <- resolveRef h
+            whnf resolveRef r
+          R.Builtin b -> pure e
       E.Ann' e _ -> whnf resolveRef e
-      E.App' (E.Ann' f _) x -> whnf resolveRef (f `E.app` x)
+      E.Apps' E.If' (cond:t:f:tl) -> do
-      E.App' (E.LetRecNamed' bs body) x -> whnf resolveRef (E.letRec bs (body `E.app` x))
+        cond <- whnf resolveRef cond
-      E.App' (E.Let1Named' v b body) x -> whnf resolveRef (E.let1 [(v,b)] (body `E.app` x))
+        case cond of
-      E.App' f x -> do
+          E.Builtin' b | Text.head b == 'F' -> whnf resolveRef f >>= \f -> (`E.apps` tl) <$> whnf resolveRef f
-        f' <- E.link resolveRef f
+                       | otherwise -> whnf resolveRef t >>= \t -> (`E.apps` tl) <$> whnf resolveRef t
-        e' <- reduce f' [x]
+          _ -> pure e
-        maybe (pure e) (whnf resolveRef) e'
+      E.Apps' f xs -> do
-      E.Let1' binding body -> whnf resolveRef (ABT.bind body binding)
+        xs <- traverse (whnf resolveRef) xs
-      E.LetRecNamed' bs body -> whnf resolveRef (ABT.substs substs body) where
+        f <- whnf resolveRef f
+        e' <- reduce resolveRef f xs
+        maybe (pure $ f `E.apps` xs) (whnf resolveRef) e'
+      E.Let1' binding body -> do
+        binding <- whnf resolveRef binding
+        whnf resolveRef (ABT.bind body binding)
+      E.LetRecNamed' bs body -> whnf resolveRef (ABT.substs bs' body) where
+        bs' = [ (v, expandBinding v b) | (v,b) <- bs ]
         expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
-        expandBinding v body = ABT.substs substs' body
+        expandBinding v body = E.letRec bs body
-          where substs' = [ (v', ABT.subst v (E.letRec bs (E.var v)) b) | (v',b) <- bs ]
+      E.Vector' es -> E.vector' <$> traverse (whnf resolveRef) es
-        substs = [ (v, expandBinding v b) | (v,b) <- bs ]
       _ -> pure e

shared/src/Unison/Metadata.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Unison.Metadata where
 
+import Control.Applicative
 import Data.Aeson
 import Data.Aeson.TH
 import Data.Text (Text)
@@ -19,6 +20,11 @@ data Metadata v h =
     description :: Maybe h
   } deriving (Eq,Ord,Show,Generic)
 
+combine :: Maybe (Metadata v h) -> Metadata v h -> Metadata v h
+combine Nothing md2 = md2
+combine (Just (Metadata _ (Names names1) desc1)) (Metadata sort (Names names2) desc2) =
+  Metadata sort (Names $ names2 ++ names1) (desc2 <|> desc1)
+
 matches :: Var v => Query -> Metadata v h -> Bool
 matches (Query txt) (Metadata _ (Names ns) _) =
   any (Text.isPrefixOf txt) (map Var.name ns)
@@ -31,9 +37,16 @@ synthetic t = Metadata t (Names []) Nothing
 syntheticTerm :: Metadata v h
 syntheticTerm = synthetic Term
 
-data Names v = Names [v] deriving (Eq,Ord,Show,Generic)
+newtype Names v = Names [v] deriving (Eq,Ord,Show,Generic)
 
-data Query = Query Text
+firstName :: Names v -> Maybe v
+firstName (Names (h:_)) = Just h
+firstName _ = Nothing
+
+allNames :: Names v -> [v]
+allNames (Names ns) = ns
+
+newtype Query = Query Text
 
 instance Show Query where
   show (Query q) = show q

shared/src/Unison/Node.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Unison.Node where
 
 -- import Data.Bytes.Serial (Serial)
 import Control.Monad
+import Control.Applicative
 import Data.Aeson.TH
 import Data.List
 import Data.Map (Map)
@@ -12,7 +14,7 @@ import Data.Set (Set)
 import Unison.Eval as Eval
 import Unison.Metadata (Metadata)
 import Unison.Node.Store (Store)
-import Unison.Note (Noted)
+import Unison.Note (Noted(..),Note(..))
 import Unison.Paths (Path)
 import Unison.Reference (Reference)
 import Unison.Term (Term)
@@ -23,11 +25,17 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Unison.Metadata as Metadata
 import qualified Unison.Node.Store as Store
+import qualified Unison.Parsers as Parsers
+import qualified Unison.Parser as Parser
 import qualified Unison.Paths as Paths
 import qualified Unison.Reference as Reference
 import qualified Unison.Term as Term
 import qualified Unison.TermEdit as TermEdit
+import qualified Unison.TermParser as TermParser
+import qualified Unison.TypeParser as TypeParser
 import qualified Unison.Typechecker as Typechecker
+import qualified Unison.Typechecker.Components as Components
+-- import Debug.Trace
 
 -- | The results of a search.
 -- On client, only need to repeat the query if we modify a character
@@ -117,9 +125,12 @@ node eval hash store =
         Reference.Builtin _ ->
           Store.writeMetadata store r md -- can't change builtin types, just metadata
         Reference.Derived h -> do
-          Store.writeTerm store h e
+          new <- (False <$ Store.readTerm store h) <|> pure True
-          Store.writeMetadata store r md
+          md0 <- (Just <$> Store.readMetadata store r) <|> pure Nothing
-          Store.annotateTerm store r t
+          Store.writeMetadata store r (Metadata.combine md0 md)
+          when new $ do
+            Store.writeTerm store h e
+            Store.annotateTerm store r t
 
     createType _ _ = error "todo - createType"
 
@@ -230,3 +241,46 @@ node eval hash store =
        types
        typeAt
        updateMetadata
+
+
+-- | Declare a group of bindings and add them to the Node.
+-- Bindings may be in any order and may refer to each other.
+-- They are broken into strongly connected components before
+-- being added, and any free variables are resolved using the
+-- existing metadata store of the Node.
+declare :: (Monad m, Var v) => (h -> Term v) -> [(v, Term v)] -> Node m v h (Type v) (Term v) -> Noted m ()
+declare ref bindings node = do
+  termBuiltins <- allTermsByVarName ref node
+  let groups = Components.components bindings
+      -- watch msg a = trace (msg ++ show (map (Var.name . fst) a)) a
+      bindings' = groups >>= \c -> case c of
+        [(v,b)] -> [(v,b)]
+        _ -> [ (v, Term.letRec c b) | (v,b) <- c ]
+      metadata v = Metadata.Metadata Metadata.Term (Metadata.Names [v]) Nothing
+      tb0 = Parsers.termBuiltins
+      step termBuiltins (v, b) = do
+        let md = metadata v
+        h <- createTerm node (Parsers.bindBuiltins (tb0 ++ termBuiltins) Parsers.typeBuiltins b) md
+        updateMetadata node h md
+        pure ((v, ref h) : termBuiltins)
+  foldM_ step termBuiltins bindings'
+
+-- | Like `declare`, but takes a `String`
+declare' :: (Monad m, Var v) => (h -> Term v) -> String -> Node m v h (Type v) (Term v) -> Noted m ()
+declare' ref bindings node = do
+  bs <- case Parser.run TermParser.moduleBindings bindings TypeParser.s0 of
+    Parser.Fail err _ -> Noted (pure $ Left (Note err))
+    Parser.Succeed bs _ _ -> pure bs
+  declare ref bs node
+
+allTermsByVarName :: (Monad m, Var v) => (h -> Term v) -> Node m v h (Type v) (Term v) -> Noted m [(v, Term v)]
+allTermsByVarName ref node = do
+  -- grab all definitions in the node
+  results <- search node Term.blank [] 1000000 (Metadata.Query "") Nothing
+  pure [ (v, ref h) | (h, md) <- references results
+                    , v <- Metadata.allNames (Metadata.names md) ]
+
+allTerms :: (Monad m, Var v) => Node m v h (Type v) (Term v) -> Noted m [(h, Term v)]
+allTerms node = do
+  hs <- map fst . references <$> search node Term.blank [] 100000 (Metadata.Query "") Nothing
+  Map.toList <$> terms node hs

shared/src/Unison/Node/BasicNode.hs

@@ -2,27 +2,20 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Unison.Node.BasicNode where
 
-import Data.Text (Text)
-import Unison.Metadata (Metadata(..))
 import Unison.Node (Node)
 import Unison.Node.Store (Store)
-import Unison.Parsers (unsafeParseTerm)
 import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import qualified Data.Map as M
-import qualified Data.Text as Text
 import qualified Unison.Eval as Eval
 import qualified Unison.Eval.Interpreter as I
-import qualified Unison.Hash as H
-import qualified Unison.Metadata as Metadata
 import qualified Unison.Node as Node
 import qualified Unison.Node.Builtin as B
 import qualified Unison.Node.Store as Store
 import qualified Unison.Note as N
 import qualified Unison.Reference as R
 import qualified Unison.Type as Type
-import qualified Unison.Var as Var
 import qualified Unison.View as View
 
 infixr 7 -->
@@ -43,28 +36,7 @@ make hash store getBuiltins =
     readTerm h = Store.readTerm store h
     whnf = Eval.whnf eval readTerm
     node = Node.node eval hash store
-
-    -- stub :: Metadata V R.Reference -> Type V -> N.Noted IO ()
-    -- stub s t = () <$ Node.createTerm node (Term.blank `Term.ann` t) s
-
   in N.run $ do
-    _ <- Node.createTerm node (unsafeParseTerm "a -> a") (prefix "identity")
     mapM_ (\(B.Builtin r _ t md) -> Node.updateMetadata node r md *> Store.annotateTerm store r t)
           builtins
-    compose <- Node.createTerm node (unsafeParseTerm "f g x -> f (g x)") (prefix "compose")
-    -- Node.createTerm node (\f -> bind (compose pure f))
-    let composeH = unsafeHashStringFromReference compose
-    _ <- Node.createTerm node (unsafeParseTerm $ "f -> bind ("++composeH++" pure f)") 
-                              (prefix "map")
     pure node
-  where
-    unsafeHashStringFromReference (R.Derived h) = "#" ++ Text.unpack (H.base64 h)
-    unsafeHashStringFromReference _ = error "tried to extract a Derived hash from a Builtin"
-
-prefix :: Text -> Metadata V h
-prefix s = prefixes [s]
-
-prefixes :: [Text] -> Metadata V h
-prefixes s = Metadata Metadata.Term
-                      (Metadata.Names (map Var.named s))
-                      Nothing

shared/src/Unison/Node/Builtin.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Unison.Node.Builtin where
 
+import Data.List
 import Data.Text (Text)
 import Unison.Metadata (Metadata(..))
 import Unison.Parsers (unsafeParseType)
@@ -8,6 +9,8 @@ import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Typechecker.Context (remoteSignatureOf)
+import Unison.Util.Logger (Logger)
+import qualified Data.Char as Char
 import qualified Data.Vector as Vector
 import qualified Data.Text as Text
 import qualified Unison.ABT as ABT
@@ -21,6 +24,7 @@ import qualified Unison.Term as Term
 import qualified Unison.Type as Type
 import qualified Unison.Var as Var
 import qualified Unison.View as View
+import qualified Unison.Util.Logger as L
 
 type DFO = View.DFO
 type V = Symbol DFO
@@ -35,9 +39,16 @@ data Builtin = Builtin
 
 unitRef :: Ord v => Term v
 unitRef = Term.ref (R.Builtin "()")
+true, false :: Ord v => Term v
+true = Term.builtin "True"
+false = Term.builtin "False"
+pair :: Ord v => Term v
+pair = Term.builtin "Pair"
+pair' :: Ord v => Term v -> Term v -> Term v
+pair' t1 t2 = pair `Term.app` t1 `Term.app` (pair `Term.app` t2 `Term.app` unitRef)
 
-makeBuiltins :: WHNFEval -> [Builtin]
+makeBuiltins :: Logger -> WHNFEval -> [Builtin]
-makeBuiltins whnf =
+makeBuiltins logger whnf =
   let
     numeric2 :: Term V -> (Double -> Double -> Double) -> I.Primop (N.Noted IO) V
     numeric2 sym f = I.Primop 2 $ \xs -> case xs of
@@ -49,90 +60,145 @@ makeBuiltins whnf =
     numericCompare sym f = I.Primop 2 $ \xs -> case xs of
       [x,y] -> g <$> whnf x <*> whnf y
         where g (Term.Number' x) (Term.Number' y) = case f x y of
-                False -> Term.builtin "False"
+                False -> false
-                True -> Term.builtin "True"
+                True -> true
               g x y = sym `Term.app` x `Term.app` y
       _ -> error "unpossible"
-    strict r n = Just (I.Primop n f)
-      where f args = reapply <$> traverse whnf (take n args)
-                      where reapply args' = Term.ref r `apps` args' `apps` drop n args
-            apps f args = foldl Term.app f args
     string2 :: Term V -> (Text -> Text -> Text) -> I.Primop (N.Noted IO) V
     string2 sym f = I.Primop 2 $ \xs -> case xs of
       [x,y] -> g <$> whnf x <*> whnf y
         where g (Term.Text' x) (Term.Text' y) = Term.lit (Term.Text (f x y))
               g x y = sym `Term.app` x `Term.app` y
       _ -> error "unpossible"
+    string2' :: Term V -> (Text -> Text -> Bool) -> I.Primop (N.Noted IO) V
+    string2' sym f = I.Primop 2 $ \xs -> case xs of
+      [x,y] -> g <$> whnf x <*> whnf y
+        where g (Term.Text' x) (Term.Text' y) = if f x y then true else false
+              g x y = sym `Term.app` x `Term.app` y
+      _ -> error "unpossible"
   in map (\(r, o, t, m) -> Builtin r o t m)
-     [ let r = R.Builtin "()"
+     [ -- Unit type
+       let r = R.Builtin "()"
        in (r, Nothing, unitT, prefix "()")
+     , let r = R.Builtin "Unit.Order"
+       in (r, Nothing, unsafeParseType "Order Unit", prefix "Unit.Order")
 
-     , let r = R.Builtin "Color.rgba"
+     -- debugging printlns
-       in (r, strict r 4, unsafeParseType "Number -> Number -> Number -> Number -> Color", prefix "rgba")
+     , let r = R.Builtin "Debug.log";
+           op [msg,logged,a] = do
+             Term.Text' msg <- whnf msg
+             logged <- whnf logged
+             N.lift $ L.error logger (Text.unpack msg ++ ": " ++ show logged)
+             whnf a
+           op _ = error "unpossible"
+           typ = "∀ a b . Text -> a -> b -> b"
+       in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "Debug.log")
 
-     -- booleans
+     , let r = R.Builtin "Debug.watch";
+           op [msg,a] = do
+             Term.Text' msg <- whnf msg
+             a <- whnf a
+             N.lift $ L.error logger (Text.unpack msg ++ ": " ++ show a)
+             pure a
+           op _ = error "unpossible"
+           typ = "∀ a . Text -> a -> a"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Debug.watch")
+
+     -- Boolean
      , let r = R.Builtin "True"
        in (r, Nothing, Type.builtin "Boolean", prefix "True")
      , let r = R.Builtin "False";
        in (r, Nothing, Type.builtin "Boolean", prefix "False")
-     , let r = R.Builtin "Boolean.if";
+     , let r = R.Builtin "Boolean.and";
-           op [cond,t,f] = do
+           op [b1,b2] = do
-             cond <- whnf cond
+             Term.Builtin' b1 <- whnf b1
-             case cond of
+             Term.Builtin' b2 <- whnf b2
-               Term.Builtin' tf -> case Text.head tf of
+             pure $ case (b1,b2) of
-                 'T' -> whnf t
+               _ | Text.head b1 /= Text.head b2 -> false
-                 'F' -> whnf f
+                 | otherwise -> if Text.head b1 == 'T' then true else false
-                 _ -> error "unpossible"
-               _ -> error "unpossible"
            op _ = error "unpossible"
-           typ = "forall a . Boolean -> a -> a -> a"
+           typ = "Boolean -> Boolean -> Boolean"
-       in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "if")
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "and")
+     , let r = R.Builtin "Boolean.or";
+           op [b1,b2] = do
+             Term.Builtin' b1 <- whnf b1
+             Term.Builtin' b2 <- whnf b2
+             pure $ case (b1,b2) of
+               _ | Text.head b1 /= Text.head b2 -> true
+                 | otherwise -> if Text.head b1 == 'F' then false else true
+           op _ = error "unpossible"
+           typ = "Boolean -> Boolean -> Boolean"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "or")
+     , let r = R.Builtin "Boolean.not";
+           op [b1] = do
+             Term.Builtin' b1 <- whnf b1
+             pure $ if Text.head b1 == 'T' then false else true
+           op _ = error "unpossible"
+           typ = "Boolean -> Boolean"
+       in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "not")
 
-     -- numbers
+     -- Number
-     , let r = R.Builtin "Number.plus"
+     , let r = R.Builtin "Number.+"
        in (r, Just (numeric2 (Term.ref r) (+)), numOpTyp, assoc 4 "+")
-     , let r = R.Builtin "Number.minus"
+     , let r = R.Builtin "Number.-"
        in (r, Just (numeric2 (Term.ref r) (-)), numOpTyp, opl 4 "-")
-     , let r = R.Builtin "Number.times"
+     , let r = R.Builtin "Number.*"
        in (r, Just (numeric2 (Term.ref r) (*)), numOpTyp, assoc 5 "*")
-     , let r = R.Builtin "Number.divide"
+     , let r = R.Builtin "Number./"
        in (r, Just (numeric2 (Term.ref r) (/)), numOpTyp, opl 5 "/")
-     , let r = R.Builtin "Number.greaterThan"
+     , let r = R.Builtin "Number.>"
-       in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 ">")
+       in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 "Number.>")
-     , let r = R.Builtin "Number.lessThan"
+     , let r = R.Builtin "Number.<"
-       in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "<")
+       in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "Number.<")
-     , let r = R.Builtin "Number.greaterThanOrEqual"
+     , let r = R.Builtin "Number.>="
-       in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 ">=")
+       in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 "Number.>=")
-     , let r = R.Builtin "Number.lessThanOrEqual"
+     , let r = R.Builtin "Number.<="
-       in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "<=")
+       in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "Number.<=")
-     , let r = R.Builtin "Number.equal"
+     , let r = R.Builtin "Number.=="
-       in (r, Just (numericCompare (Term.ref r) (==)), numCompareTyp, opl 3 "==")
+       in (r, Just (numericCompare (Term.ref r) (==)), numCompareTyp, opl 3 "Number.==")
+     , let r = R.Builtin "Number.Order"
+       in (r, Nothing, unsafeParseType "Order Number", prefix "Number.Order")
 
-     -- remote computations
+     -- Duration
+     , let r = R.Builtin "Duration.seconds"
+           op [n] = do
+             Term.Number' n <- whnf n
+             pure $ Term.num n
+           op _ = fail "Duration.seconds unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "Number -> Duration", prefix "Duration.seconds")
+
+     -- Remote
+     , let r = R.Builtin "Remote.sleep"
+           op [seconds] = do
+             Term.Number' seconds <- whnf seconds
+             let s = Remote.Seconds seconds
+             pure $ Term.remote (Remote.Step (Remote.Local (Remote.Sleep s)))
+           op _ = fail "Remote.sleep unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "Duration -> Remote Unit", prefix "Remote.sleep")
      , let r = R.Builtin "Remote.at"
            op [node,term] = do
              Term.Distributed' (Term.Node node) <- whnf node
              pure $ Term.remote (Remote.Step (Remote.At node term))
            op _ = fail "Remote.at unpossible"
-       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.at", prefix "at")
+       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.at", prefix "Remote.at")
      , let r = R.Builtin "Remote.here"
            op [] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Here)))
            op _ = fail "Remote.here unpossible"
-       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.here", prefix "here")
+       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.here", prefix "Remote.here")
      , let r = R.Builtin "Remote.spawn"
            op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.Spawn))
            op _ = fail "Remote.spawn unpossible"
-       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.spawn", prefix "spawn")
+       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.spawn", prefix "Remote.spawn")
      , let r = R.Builtin "Remote.send"
            op [c, v] = do
              Term.Distributed' (Term.Channel c) <- whnf c
              pure $ Term.remote (Remote.Step (Remote.Local (Remote.Send c v)))
            op _ = fail "Remote.send unpossible"
-       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.send", prefix "send")
+       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.send", prefix "Remote.send")
      , let r = R.Builtin "Remote.channel"
            op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.CreateChannel))
            op _ = fail "Remote.channel unpossible"
-       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.channel", prefix "channel")
+       in (r, Just (I.Primop 0 op), remoteSignatureOf "Remote.channel", prefix "Remote.channel")
     , let r = R.Builtin "Remote.bind"
           op [g, r] = do
             r <- whnf r
@@ -142,53 +208,129 @@ makeBuiltins whnf =
               Term.Distributed' (Term.Remote (Remote.Step s)) -> pure $ Term.remote (Remote.Bind s g)
               Term.Distributed' (Term.Remote (Remote.Bind s f)) -> pure $ Term.remote (Remote.Bind s (kcomp f g))
               _ -> fail $ "Remote.bind given a value that was not a Remote: " ++ show r
+                        ++ " "
+                        ++ show (ABT.freeVars r)
           op _ = fail "Remote.bind unpossible"
-       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.bind", prefix "bind")
+       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.bind", prefix "Remote.bind")
      , let r = R.Builtin "Remote.pure"
            op [a] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Pure a)))
            op _ = fail "unpossible"
-       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.pure", prefix "pure")
+       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.pure", prefix "Remote.pure")
      , let r = R.Builtin "Remote.map"
            op [f, r] = pure $ Term.builtin "Remote.bind" `Term.app`
              (Term.lam' ["x"] $ Term.remote
                (Remote.Step . Remote.Local . Remote.Pure $ f `Term.app` Term.var' "x"))
              `Term.app` r
            op _ = fail "unpossible"
-       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "map")
+       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "Remote.map")
-     , let r = R.Builtin "Remote.receiveAsync"
+     , let r = R.Builtin "Remote.receive-async"
            op [chan, timeout] = do
              Term.Number' seconds <- whnf timeout
              Term.Distributed' (Term.Channel chan) <- whnf chan
              pure $ Term.remote (Remote.Step (Remote.Local (Remote.ReceiveAsync chan (Remote.Seconds seconds))))
            op _ = fail "unpossible"
-       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.receiveAsync", prefix "receiveAsync")
+       in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.receive-async", prefix "Remote.receive-async")
      , let r = R.Builtin "Remote.receive"
            op [chan] = do
              Term.Distributed' (Term.Channel chan) <- whnf chan
              pure $ Term.remote (Remote.Step (Remote.Local (Remote.Receive chan)))
            op _ = fail "unpossible"
-       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.receive", prefix "receive")
+       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.receive", prefix "Remote.receive")
      , let r = R.Builtin "Remote.fork"
            op [r] = do
              Term.Distributed' (Term.Remote r) <- whnf r
              pure $ Term.remote (Remote.Step (Remote.Local (Remote.Fork r)))
            op _ = fail "unpossible"
-       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.fork", prefix "fork")
+       in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.fork", prefix "Remote.fork")
-
-     , let r = R.Builtin "Symbol.Symbol"
-       in (r, Nothing, unsafeParseType "Text -> Fixity -> Number -> Symbol", prefix "Symbol")
 
+     -- Text
      , let r = R.Builtin "Text.concatenate"
-       in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
+       in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefix "Text.concatenate")
-     , let r = R.Builtin "Text.left"
+     , let r = R.Builtin "Text.=="
-       in (r, Nothing, alignmentT, prefixes ["left", "Text"])
+       in (r, Just (string2' (Term.ref r) (==)), textCompareTyp, prefix "Text.==")
-     , let r = R.Builtin "Text.right"
+     , let r = R.Builtin "Text.<"
-       in (r, Nothing, alignmentT, prefixes ["right", "Text"])
+       in (r, Just (string2' (Term.ref r) (<)), textCompareTyp, prefix "Text.<")
-     , let r = R.Builtin "Text.center"
+     , let r = R.Builtin "Text.<="
-       in (r, Nothing, alignmentT, prefixes ["center", "Text"])
+       in (r, Just (string2' (Term.ref r) (<=)), textCompareTyp, prefix "Text.<=")
-     , let r = R.Builtin "Text.justify"
+     , let r = R.Builtin "Text.>"
-       in (r, Nothing, alignmentT, prefixes ["justify", "Text"])
+       in (r, Just (string2' (Term.ref r) (>)), textCompareTyp, prefix "Text.>")
+     , let r = R.Builtin "Text.>="
+       in (r, Just (string2' (Term.ref r) (>=)), textCompareTyp, prefix "Text.>=")
+     , let r = R.Builtin "Text.Order"
+       in (r, Nothing, unsafeParseType "Order Text", prefix "Text.Order")
+     , let r = R.Builtin "Text.lowercase"
+           op [Term.Text' txt] = pure $ Term.text (Text.toLower txt)
+           op _ = error "Text.lowercase unpossible"
+           typ = "Text -> Text"
+       in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.lowercase")
+     , let r = R.Builtin "Text.uppercase"
+           op [Term.Text' txt] = pure $ Term.text (Text.toUpper txt)
+           op _ = error "Text.uppercase unpossible"
+           typ = "Text -> Text"
+       in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.lowercase")
+     , let r = R.Builtin "Text.take"
+           op [Term.Number' n, Term.Text' txt] = pure $ Term.text (Text.take (floor n) txt)
+           op _ = error "Text.take unpossible"
+           typ = "Number -> Text -> Text"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Text.take")
+     , let r = R.Builtin "Text.drop"
+           op [Term.Number' n, Term.Text' txt] = pure $ Term.text (Text.drop (floor n) txt)
+           op _ = error "Text.drop unpossible"
+           typ = "Number -> Text -> Text"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Text.drop")
+     , -- todo: rather special purpose, remove this in favor of more generic regex
+       let r = R.Builtin "Text.words"
+           op [Term.Text' txt] = pure $
+             let words = map stripPunctuation $ Text.split Char.isSpace txt
+                 stripPunctuation word = Text.dropAround (not . Char.isAlphaNum) word
+             in Term.vector (map Term.text . filter (not . Text.null) $ words)
+           op _ = error "Text.words unpossible"
+           typ = "Text -> Vector Text"
+       in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.words")
 
+     -- Pair
+     , let r = R.Builtin "Pair"
+       in (r, Nothing, unsafeParseType "forall a b . a -> b -> Pair a b", prefix "Pair")
+     , let r = R.Builtin "Pair.fold"
+           op [f,p] = do
+             p <- whnf p
+             case p of
+               Term.Apps' (Term.Builtin' "Pair") [a,b] -> whnf (f `Term.apps` [a,b])
+               p -> fail $ "expected pair, got: " ++ show p
+           op _ = error "Pair.fold unpossible"
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a b c . (a -> b -> c) -> Pair a b -> c", prefix "Pair.fold")
+     , let r = R.Builtin "Pair.Order"
+       in (r, Nothing, unsafeParseType "forall a b . Order a -> Order b -> Order (Pair a b)", prefix "Pair.Order")
+
+     -- Either
+     , let r = R.Builtin "Either.Left"
+       in (r, Nothing, unsafeParseType "forall a b . a -> Either a b", prefix "Left")
+     , let r = R.Builtin "Either.Right"
+       in (r, Nothing, unsafeParseType "forall a b . b -> Either a b", prefix "Right")
+     , let r = R.Builtin "Either.fold"
+           op [fa,fb,e] = do
+             Term.App' (Term.Builtin' tag) aOrB <- whnf e
+             case tag of
+               _ | tag == "Either.Left" -> whnf (fa `Term.app` aOrB)
+                 | tag == "Either.Right" -> whnf (fb `Term.app` aOrB)
+                 | otherwise -> error "type errror"
+           op _ = error "Either.fold unpossible"
+       in (r, Just (I.Primop 3 op), unsafeParseType "forall a b r . (a -> r) -> (b -> r) -> Either a b -> r", prefix "Either.fold")
+
+     -- Optional
+     , let r = R.Builtin "Optional.None"
+       in (r, Nothing, unsafeParseType "forall a . Optional a", prefix "None")
+     , let r = R.Builtin "Optional.Some"
+       in (r, Nothing, unsafeParseType "forall a . a -> Optional a", prefix "Some")
+     , let r = R.Builtin "Optional.fold"
+           op [fz,f,o] = whnf o >>= \o -> case o of
+             Term.Builtin' tag | tag == "Optional.None" -> whnf fz
+             Term.App' (Term.Builtin' tag) a | tag == "Optional.Some" -> whnf (f `Term.app` a)
+             _ -> error $ "Optional.fold unpossible: " ++ show o
+           op _ = error "Optional.fold unpossible"
+       in (r, Just (I.Primop 3 op), unsafeParseType "forall a r . r -> (a -> r) -> Optional a -> r", prefix "Optional.fold")
+
+     -- Vector
      , let r = R.Builtin "Vector.append"
            op [last,init] = do
              initr <- whnf init
@@ -196,7 +338,7 @@ makeBuiltins whnf =
                Term.Vector' init -> Term.vector' (Vector.snoc init last)
                init -> Term.ref r `Term.app` last `Term.app` init
            op _ = fail "Vector.append unpossible"
-       in (r, Just (I.Primop 2 op), unsafeParseType "forall a. a -> Vector a -> Vector a", prefix "append")
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a . a -> Vector a -> Vector a", prefix "Vector.append")
      , let r = R.Builtin "Vector.concatenate"
            op [a,b] = do
              ar <- whnf a
@@ -205,17 +347,101 @@ makeBuiltins whnf =
                (Term.Vector' a, Term.Vector' b) -> Term.vector' (a `mappend` b)
                (a,b) -> Term.ref r `Term.app` a `Term.app` b
            op _ = fail "Vector.concatenate unpossible"
-       in (r, Just (I.Primop 2 op), unsafeParseType "forall a. Vector a -> Vector a -> Vector a", prefix "concatenate")
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a . Vector a -> Vector a -> Vector a", prefix "Vector.concatenate")
      , let r = R.Builtin "Vector.empty"
            op [] = pure $ Term.vector mempty
            op _ = fail "Vector.empty unpossible"
-       in (r, Just (I.Primop 0 op), unsafeParseType "forall a. Vector a", prefix "empty")
+       in (r, Just (I.Primop 0 op), unsafeParseType "forall a . Vector a", prefix "Vector.empty")
+     , let r = R.Builtin "Vector.range"
+           op [start,stop] = do
+             Term.Number' start <- whnf start
+             Term.Number' stop <- whnf stop
+             let num = Term.num . fromIntegral
+                 ns = [floor start .. floor stop - (1 :: Int)]
+             pure $ Term.vector' (Vector.fromList . map num $ ns)
+           op _ = fail "Vector.range unpossible"
+           typ = unsafeParseType "Number -> Number -> Vector Number"
+       in (r, Just (I.Primop 2 op), typ, prefix "Vector.range")
+     , let r = R.Builtin "Vector.empty?"
+           op [v] = do
+             Term.Vector' vs <- whnf v
+             pure $ if Vector.null vs then true else false
+           op _ = fail "Vector.empty? unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "forall a . Vector a -> Boolean", prefix "empty?")
+     , let r = R.Builtin "Vector.zip"
+           op [v,v2] = do
+             Term.Vector' vs <- whnf v
+             Term.Vector' vs2 <- whnf v2
+             pure $ Term.vector' (Vector.zipWith pair' vs vs2)
+           op _ = fail "Vector.zip unpossible"
+           typ = "∀ a b . Vector a -> Vector b -> Vector (a,b)"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Vector.zip")
+     , let r = R.Builtin "Vector.sort-keyed"
+           op [f,v] = do
+             Term.Vector' vs <- whnf v
+             ks <- traverse (whnf . Term.app f) vs
+             ks <- pure $ fmap extractKey ks
+             let sortableVs = Vector.zip ks vs
+                 f' (a, _) (b, _) = a `compare` b
+             pure . Term.vector . fmap snd $ sortBy f' (Vector.toList sortableVs)
+           op _ = fail "Vector.sort-keyed unpossible"
+           typ = "∀ a k . (a -> Order.Key k) -> Vector a -> Vector a"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Vector.sort-keyed")
+     , let r = R.Builtin "Vector.size"
+           op [v] = do
+             Term.Vector' vs <- whnf v
+             pure $ Term.num (fromIntegral $ Vector.length vs)
+           op _ = fail "Vector.size unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "forall a . Vector a -> Number", prefix "Vector.size")
+     , let r = R.Builtin "Vector.reverse"
+           op [v] = do
+             Term.Vector' vs <- whnf v
+             pure $ Term.vector' (Vector.reverse vs)
+           op _ = fail "Vector.reverse unpossible"
+       in (r, Just (I.Primop 1 op), unsafeParseType "forall a . Vector a -> Vector a", prefix "Vector.reverse")
+     , let r = R.Builtin "Vector.halve"
+           op [v] = do
+             Term.Vector' vs <- whnf v
+             pure $ case Vector.null vs of
+               True -> pair' (Term.vector []) (Term.vector [])
+               False -> case Vector.splitAt (Vector.length vs `div` 2) vs of
+                 (x,y) -> pair' (Term.vector' x) (Term.vector' y)
+           op _ = fail "Vector.halve unpossible"
+           typ = "forall a . Vector a -> (Vector a, Vector a)"
+       in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Vector.halve")
+     , let r = R.Builtin "Vector.at"
+           op [n,vec] = do
+             Term.Number' n <- whnf n
+             Term.Vector' vs <- whnf vec
+             pure $ case vs Vector.!? (floor n) of
+               Nothing -> none
+               Just t -> some t
+           op _ = fail "Vector.at unpossible"
+           typ = "forall a . Number -> Vector a -> Optional a"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Vector.at")
+     , let r = R.Builtin "Vector.take"
+           op [n,vec] = do
+             Term.Number' n <- whnf n
+             Term.Vector' vs <- whnf vec
+             pure $ Term.vector' (Vector.take (floor n) vs)
+           op _ = fail "Vector.take unpossible"
+           typ = "forall a . Number -> Vector a -> Vector a"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Vector.take")
+     , let r = R.Builtin "Vector.drop"
+           op [n,vec] = do
+             Term.Number' n <- whnf n
+             Term.Vector' vs <- whnf vec
+             pure $ Term.vector' (Vector.drop (floor n) vs)
+           op _ = fail "Vector.drop unpossible"
+           typ = "forall a . Number -> Vector a -> Vector a"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Vector.drop")
      , let r = R.Builtin "Vector.fold-left"
            op [f,z,vec] = whnf vec >>= \vec -> case vec of
              Term.Vector' vs -> Vector.foldM (\acc a -> whnf (f `Term.apps` [acc, a])) z vs
              _ -> pure $ Term.ref r `Term.app` vec
            op _ = fail "Vector.fold-left unpossible"
-       in (r, Just (I.Primop 3 op), unsafeParseType "forall a b. (b -> a -> b) -> b -> Vector a -> b", prefix "fold-left")
+           typ = "forall a b . (b -> a -> b) -> b -> Vector a -> b"
+       in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "Vector.fold-left")
      , let r = R.Builtin "Vector.map"
            op [f,vec] = do
              vecr <- whnf vec
@@ -223,7 +449,7 @@ makeBuiltins whnf =
                Term.Vector' vs -> Term.vector' (fmap (Term.app f) vs)
                _ -> Term.ref r `Term.app` vecr
            op _ = fail "Vector.map unpossible"
-       in (r, Just (I.Primop 2 op), unsafeParseType "forall a b. (a -> b) -> Vector a -> Vector b", prefix "map")
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a b . (a -> b) -> Vector a -> Vector b", prefix "Vector.map")
      , let r = R.Builtin "Vector.prepend"
            op [hd,tl] = do
              tlr <- whnf tl
@@ -231,13 +457,103 @@ makeBuiltins whnf =
                Term.Vector' tl -> Term.vector' (Vector.cons hd tl)
                tl -> Term.ref r `Term.app` hd `Term.app` tl
            op _ = fail "Vector.prepend unpossible"
-       in (r, Just (I.Primop 2 op), unsafeParseType "forall a. a -> Vector a -> Vector a", prefix "prepend")
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a . a -> Vector a -> Vector a", prefix "Vector.prepend")
      , let r = R.Builtin "Vector.single"
            op [hd] = pure $ Term.vector (pure hd)
            op _ = fail "Vector.single unpossible"
-       in (r, Just (I.Primop 1 op), unsafeParseType "forall a. a -> Vector a", prefix "single")
+       in (r, Just (I.Primop 1 op), unsafeParseType "forall a . a -> Vector a", prefix "Vector.single")
+
+     , let r = R.Builtin "Order.invert"
+       in (r, Nothing, unsafeParseType "forall a . Order a -> Order a", prefix "Order.invert")
+     , let r = R.Builtin "Order.ignore"
+       in (r, Nothing, unsafeParseType "forall a . Order a", prefix "Order.ignore")
+
+     , let r = R.Builtin "Less"
+       in (r, Nothing, unsafeParseType "Comparison", prefix "Less")
+     , let r = R.Builtin "Greater"
+       in (r, Nothing, unsafeParseType "Comparison", prefix "Greater")
+     , let r = R.Builtin "Equal"
+       in (r, Nothing, unsafeParseType "Comparison", prefix "Equal")
+     , let r = R.Builtin "Comparison.fold"
+           op [lt,eq,gt,c] = do
+             Term.Builtin' c <- whnf c
+             case Text.head c of
+               'L' -> whnf lt
+               'E' -> whnf eq
+               'G' -> whnf gt
+               _ -> fail $ "Comparison.fold not one of {Less,Equal,Greater}" ++ show c
+           op _ = error "Comparison.fold unpossible"
+       in (r, Just (I.Primop 4 op), unsafeParseType "∀ r . r -> r -> r -> Comparison -> r", prefix "Comparison.fold")
+
+     , let r = R.Builtin "Order.Key.compare"
+           op [a,b] = do
+             a <- whnf a
+             b <- whnf b
+             pure $ case compareKeys a b of
+               LT -> Term.builtin "Less"
+               EQ -> Term.builtin "Equal"
+               GT -> Term.builtin "Greater"
+           op _ = error "Order.Key.compare unpossible"
+           typ = "∀ a . Order.Key a -> Order.Key a -> Comparison"
+       in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Order.Key.compare")
+
+     , let r = R.Builtin "Order.key"
+           flip ts = (map neg (ts []) ++) where
+             neg (Term.Text' t) = Term.text (Text.reverse t)
+             neg (Term.Number' n) = Term.num (negate n)
+             neg t@(Term.Builtin' _) = t
+             neg t = error $ "don't know how to negate " ++ show t
+           op' ord a = do
+             ord <- whnf ord
+             case ord of
+               Term.App' (Term.Builtin' invert) ord
+                 | invert == "Order.invert" -> flip <$> op' ord a
+               Term.Builtin' b
+                 | b == "Text.Order" -> do a <- whnf a; pure (a:)
+                 | b == "Number.Order" -> do a <- whnf a; pure (a:)
+                 | b == "Hash.Order" -> do Term.App' _ a <- whnf a; pure (a:)
+                 | b == "Unit.Order" -> do a <- whnf a; pure (a:)
+                 | b == "Order.ignore" -> pure id
+                 | otherwise -> fail $ "unrecognized order type: " ++ Text.unpack b
+               Term.Apps' (Term.Builtin' pair) [ord1, ord2]
+                 | pair == "Pair.Order" -> do
+                     Term.Apps' _ [a,b] <- whnf a
+                     (.) <$> op' ord1 a <*> op' ord2 b
+                 | otherwise -> fail $ "unrecognized order type: " ++ Text.unpack pair
+           op [ord,a] = Term.app (Term.builtin "Order.Key")
+                      . foldr Term.app unitRef
+                      . ($ [])
+                    <$> op' ord a
+           op _ = fail "Order.key unpossible"
+       in (r, Just (I.Primop 2 op), unsafeParseType "forall a . Order a -> a -> Order.Key a", prefix "Order.key")
      ]
 
+extractKey :: Term V -> [Either Double Text]
+extractKey (Term.App' _ t1) = go t1 where
+  go (Term.Builtin' _) = []
+  go (Term.App' (Term.Text' t) tl) = Right t : go tl
+  go (Term.App' (Term.Number' n) tl) = Left n : go tl
+  go (Term.App' (Term.Builtin' b) tl) = Right b : go tl
+  go _ = error $ "don't know what to do with this in extractKey: " ++ show t1
+extractKey t = error $ "not a key: " ++ show t
+
+compareKeys :: Term V -> Term V -> Ordering
+compareKeys (Term.App' _ t1) (Term.App' _ t2) = go t1 t2 where
+  go (Term.Builtin' u) (Term.Builtin' u2) = u `compare` u2
+  go (Term.App' h1 t1) (Term.App' h2 t2) =
+    let go' :: Ord a => a -> a -> Ordering
+        go' a a2 = case a `compare` a2 of
+          EQ -> go t1 t2
+          done -> done
+    in
+      case (h1,h2) of
+        (Term.Text' h1, Term.Text' h2) -> go' h1 h2
+        (Term.Number' h1, Term.Number' h2) -> go' h1 h2
+        (Term.Builtin' h1, Term.Builtin' h2) -> go' h1 h2
+  go (Term.App' _ _) _ = GT
+  go _ _ = LT
+compareKeys _ _ = error "not a key"
+
 -- type helpers
 alignmentT :: Ord v => Type v
 alignmentT = Type.ref (R.Builtin "Alignment")
@@ -245,6 +561,8 @@ numOpTyp :: Type V
 numOpTyp = unsafeParseType "Number -> Number -> Number"
 numCompareTyp :: Type V
 numCompareTyp = unsafeParseType "Number -> Number -> Boolean"
+textCompareTyp :: Type V
+textCompareTyp = unsafeParseType "Text -> Text -> Boolean"
 strOpTyp :: Type V
 strOpTyp = unsafeParseType "Text -> Text -> Text"
 unitT :: Ord v => Type v

shared/src/Unison/Node/MemNode.hs

@@ -9,9 +9,10 @@ import Unison.Node.Store (Store)
 import Unison.Reference (Reference(Derived))
 import Unison.Term (Term)
 import Unison.Type (Type)
+import Unison.Util.Logger (Logger)
 import Unison.Var (Var)
-import qualified Data.ByteString.Lazy as LB
 import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Lazy as LB
 import qualified Data.Digest.Murmur64 as Murmur
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
@@ -44,7 +45,7 @@ instance Hashable.Accumulate Hash where
 
 type V = Symbol.Symbol View.DFO
 
-make :: IO (Node IO V Reference (Type V) (Term V))
+make :: Logger -> IO (Node IO V Reference (Type V) (Term V))
-make = do
+make logger = do
   store <- MemStore.make :: IO (Store IO V)
-  BasicNode.make hash store Builtin.makeBuiltins
+  BasicNode.make hash store (Builtin.makeBuiltins logger)

shared/src/Unison/Note.hs

@@ -63,6 +63,18 @@ instance Applicative m => Applicative (Noted m) where
   pure = Noted . pure . pure
   (Noted f) <*> (Noted a) = Noted $ liftA2 (<*>) f a
 
+instance Monad m => MonadPlus (Noted m) where
+  mzero = Noted (pure (Left (Note [])))
+  mplus (Noted n1) (Noted n2) = Noted $ do
+    n1 <- n1
+    case n1 of
+      Left _ -> n2
+      Right a -> pure (Right a)
+
+instance Monad m => Alternative (Noted m) where
+  empty = mzero
+  (<|>) = mplus
+
 note :: String -> Note
 note s = Note [s]
 

shared/src/Unison/Parser.hs

@@ -1,3 +1,7 @@
+{-# Language DeriveFunctor #-}
+{-# Language DeriveTraversable #-}
+{-# Language DeriveFoldable #-}
+
 module Unison.Parser where
 
 import Control.Applicative
@@ -8,54 +12,70 @@ import Data.Maybe
 import Prelude hiding (takeWhile)
 import qualified Data.Char as Char
 import qualified Prelude
+import Debug.Trace
 
-newtype Parser a = Parser { run :: String -> Result a }
+data Env s =
+  Env { overallInput :: String
+      , offset :: !Int
+      , state :: !s
+      , currentInput :: String } -- always just `drop offset overallInput`
 
-root :: Parser a -> Parser a
+newtype Parser s a = Parser { run' :: Env s -> Result s a }
-root p = many (whitespace1 <|> haskellLineComment) *> (p <* eof)
 
-eof :: Parser ()
+root :: Parser s a -> Parser s a
-eof = Parser $ \s -> case s of
+root p = ignored *> (p <* (optional semicolon <* eof))
-  [] -> Succeed () 0 False
-  _ -> Fail [Prelude.takeWhile (/= '\n') s, "expected eof, got"] False
 
-attempt :: Parser a -> Parser a
+semicolon :: Parser s ()
-attempt p = Parser $ \s -> case run p s of
+semicolon = void $ token (char ';')
+
+semicolon2 :: Parser s ()
+semicolon2 = semicolon *> semicolon
+
+eof :: Parser s ()
+eof = Parser $ \env -> case (currentInput env) of
+  [] -> Succeed () (state env) 0
+  _ -> Fail [Prelude.takeWhile (/= '\n') (currentInput env), "expected eof"] False
+
+attempt :: Parser s a -> Parser s a
+attempt p = Parser $ \s -> case run' p s of
    Fail stack _ -> Fail stack False
-   Succeed a n _ -> Succeed a n False
+   succeed -> succeed
 
-unsafeRun :: Parser a -> String -> a
+run :: Parser s a -> String -> s -> Result s a
-unsafeRun p s = case toEither $ run p s of
+run p s s0 = run' p (Env s 0 s0 s)
+
+unsafeRun :: Parser s a -> String -> s -> a
+unsafeRun p s s0 = case toEither $ run p s s0 of
   Right a -> a
   Left e -> error ("Parse error:\n" ++ e)
 
-unsafeGetSucceed :: Result a -> a
+unsafeGetSucceed :: Result s a -> a
 unsafeGetSucceed r = case r of
   Succeed a _ _ -> a
   Fail e _ -> error (unlines ("Parse error:":e))
 
-string :: String -> Parser String
+string :: String -> Parser s String
-string s = Parser $ \input ->
+string s = Parser $ \env ->
-  if s `isPrefixOf` input then Succeed s (length s) False
+  if s `isPrefixOf` (currentInput env) then Succeed s (state env) (length s)
-  else Fail ["expected '" ++ s ++ "', got " ++ takeLine input] False
+  else Fail ["expected " ++ s ++ ", got " ++ takeLine (currentInput env)] False
 
 takeLine :: String -> String
 takeLine = Prelude.takeWhile (/= '\n')
 
-char :: Char -> Parser Char
+char :: Char -> Parser s Char
-char c = Parser $ \input ->
+char c = Parser $ \env ->
-  if listToMaybe input == Just c then Succeed c 1 False
+  if listToMaybe (currentInput env) == Just c then Succeed c (state env) 1
-  else Fail [] False
+  else Fail ["expected " ++ show c ++ ", got " ++ takeLine (currentInput env)] False
 
-one :: (Char -> Bool) -> Parser Char
+one :: (Char -> Bool) -> Parser s Char
-one f = Parser $ \s -> case s of
+one f = Parser $ \env -> case (currentInput env) of
-  (h:_) | f h -> Succeed h 1 False
+  (h:_) | f h -> Succeed h (state env) 1
   _ -> Fail [] False
 
-base64string' :: String -> Parser String
+base64string' :: String -> Parser s String
 base64string' alphabet = concat <$> many base64group
   where
-    base64group :: Parser String
+    base64group :: Parser s String
     base64group = do
       chars <- some $ one (`elem` alphabet)
       padding <- sequenceA (replicate (padCount $ length chars) (char '='))
@@ -63,122 +83,148 @@ base64string' alphabet = concat <$> many base64group
     padCount :: Int -> Int
     padCount len = case len `mod` 4 of 0 -> 0; n -> 4 - n
 
-base64urlstring :: Parser String
+base64urlstring :: Parser s String
 base64urlstring = base64string' $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_"
 
 notReservedChar :: Char -> Bool
 notReservedChar = (`notElem` "\".,`[]{}:;()")
 
-identifier :: [String -> Bool] -> Parser String
+identifier :: [String -> Bool] -> Parser s String
 identifier = identifier' [not . isSpace, notReservedChar]
 
-identifier' :: [Char -> Bool] -> [String -> Bool] -> Parser String
+identifier' :: [Char -> Bool] -> [String -> Bool] -> Parser s String
 identifier' charTests stringTests = do
   i <- takeWhile1 "identifier" (\c -> all ($ c) charTests)
   guard (all ($ i) stringTests)
   pure i
 
-token :: Parser a -> Parser a
+-- a wordyId isn't all digits, isn't all symbols, and isn't a symbolyId
-token p = p <* many (whitespace1 <|> haskellLineComment)
+wordyId :: [String] -> Parser s String
+wordyId keywords = do
+  op <- (False <$ symbolyId keywords) <|> pure True
+  guard op
+  token $ f <$> sepBy1 dot id
+  where
+    dot = char '.'
+    id = identifier [any (not . Char.isDigit), any Char.isAlphaNum, (`notElem` keywords)]
+    f segs = intercalate "." segs
 
-haskellLineComment :: Parser ()
+-- a symbolyId is all symbols
+symbolyId :: [String] -> Parser s String
+symbolyId keywords = scope "operator" . token $ do
+  op <- identifier'
+    [notReservedChar, (/= '_'), not . Char.isSpace, \c -> Char.isSymbol c || Char.isPunctuation c]
+    [(`notElem` keywords)]
+  qual <- optional (char '_' *> wordyId keywords)
+  pure $ maybe op (\qual -> qual ++ "." ++ op) qual
+
+token :: Parser s a -> Parser s a
+token p = p <* ignored
+
+haskellLineComment :: Parser s ()
 haskellLineComment = void $ string "--" *> takeWhile "-- comment" (/= '\n')
 
-lineErrorUnless :: String -> Parser a -> Parser a
+lineErrorUnless :: String -> Parser s a -> Parser s a
-lineErrorUnless s p = commitFail $ Parser $ \input -> case run p input of
+lineErrorUnless s = commit . scope s
-    Fail e b -> Fail (s:m:e) b
-      where m = "near \'" ++ Prelude.takeWhile (/= '\n') input ++ "\'"
-    ok -> ok
 
-parenthesized :: Parser a -> Parser a
+currentLine' :: Env s -> String
+currentLine' (Env overall i s cur) = before ++ restOfLine where
+  -- this grabs the current line up to current offset, i
+  before = reverse . Prelude.takeWhile (/= '\n') . reverse . take i $ overall
+  restOfLine = Prelude.takeWhile (/= '\n') cur
+
+currentLine :: Parser s String
+currentLine = Parser $ \env -> Succeed (currentLine' env) (state env) 0
+
+parenthesized :: Parser s a -> Parser s a
 parenthesized p = lp *> body <* rp
   where
     lp = token (char '(')
     body = p
     rp = lineErrorUnless "missing )" $ token (char ')')
 
-takeWhile :: String -> (Char -> Bool) -> Parser String
+takeWhile :: String -> (Char -> Bool) -> Parser s String
-takeWhile msg f = scope msg . Parser $ \s ->
+takeWhile msg f = scope msg . Parser $ \(Env _ _ s cur) ->
-  let hd = Prelude.takeWhile f s
+  let hd = Prelude.takeWhile f cur
-  in Succeed hd (length hd) False
+  in Succeed hd s (length hd)
 
-takeWhile1 :: String -> (Char -> Bool) -> Parser String
+takeWhile1 :: String -> (Char -> Bool) -> Parser s String
-takeWhile1 msg f = scope msg . Parser $ \s ->
+takeWhile1 msg f = scope msg . Parser $ \(Env _ _ s cur) ->
-  let hd = Prelude.takeWhile f s
+  let hd = Prelude.takeWhile f cur
-  in if null hd then Fail ["takeWhile1 empty: " ++ take 20 s] False
+  in if null hd then Fail [] False
-     else Succeed hd (length hd) False
+     else Succeed hd s (length hd)
 
-whitespace :: Parser ()
+whitespace :: Parser s ()
 whitespace = void $ takeWhile "whitespace" Char.isSpace
 
-whitespace1 :: Parser ()
+whitespace1 :: Parser s ()
 whitespace1 = void $ takeWhile1 "whitespace1" Char.isSpace
 
-nonempty :: Parser a -> Parser a
+nonempty :: Parser s a -> Parser s a
-nonempty p = Parser $ \s -> case run p s of
+nonempty p = Parser $ \s -> case run' p s of
-  Succeed _ 0 b -> Fail [] b
+  Succeed _ _ 0 -> Fail [] False
   ok -> ok
 
-scope :: String -> Parser a -> Parser a
+scope :: String -> Parser s a -> Parser s a
-scope s p = Parser $ \input -> case run p input of
+scope s p = Parser $ \env -> case run' p env of
-  Fail e b -> Fail (s:e) b
+  Fail e b -> Fail (currentLine' env : s:e) b
   ok -> ok
 
-commitSuccess :: Parser a -> Parser a
+commit :: Parser s a -> Parser s a
-commitSuccess p = Parser $ \input -> case run p input of
+commit p = Parser $ \input -> case run' p input of
-  Fail e b -> Fail e b
-  Succeed a n _ -> Succeed a n True
-
-commitFail :: Parser a -> Parser a
-commitFail p = Parser $ \input -> case run p input of
   Fail e _ -> Fail e True
-  Succeed a n b -> Succeed a n b
+  Succeed a s n -> Succeed a s n
 
-commit' :: Parser ()
+sepBy :: Parser s a -> Parser s b -> Parser s [b]
-commit' = commitSuccess (pure ())
-
-failWith :: String -> Parser a
-failWith error = Parser . const $ Fail [error] False
-
-sepBy :: Parser a -> Parser b -> Parser [b]
 sepBy sep pb = f <$> optional (sepBy1 sep pb)
   where
     f Nothing = []
     f (Just l) = l
 
-sepBy1 :: Parser a -> Parser b -> Parser [b]
+sepBy1 :: Parser s a -> Parser s b -> Parser s [b]
 sepBy1 sep pb = (:) <$> pb <*> many (sep *> pb)
 
-toEither :: Result a -> Either String a
+ignored :: Parser s ()
+ignored = void $ many (whitespace1 <|> haskellLineComment)
+
+toEither :: Result s a -> Either String a
 toEither (Fail e _) = Left (intercalate "\n" e)
 toEither (Succeed a _ _) = Right a
 
-data Result a
+data Result s a
-  = Fail [String] Bool
+  = Fail [String] !Bool
-  | Succeed a Int Bool
+  | Succeed a s !Int
-  deriving (Show)
+  deriving (Show,Functor,Foldable,Traversable)
 
-instance Functor Parser where
+get :: Parser s s
+get = Parser (\env -> Succeed (state env) (state env) 0)
+
+set :: s -> Parser s ()
+set s = Parser (\env -> Succeed () s 0)
+
+instance Functor (Parser s) where
   fmap = liftM
 
-instance Applicative Parser where
+instance Applicative (Parser s) where
   pure = return
   (<*>) = ap
 
-instance Alternative Parser where
+instance Alternative (Parser s) where
   empty = mzero
   (<|>) = mplus
 
-instance Monad Parser where
+instance Monad (Parser s) where
-  return a = Parser $ \_ -> Succeed a 0 False
+  return a = Parser $ \env -> Succeed a (state env) 0
-  Parser p >>= f = Parser $ \s -> case p s of
+  Parser p >>= f = Parser $ \env@(Env overall i s cur) -> case p env of
-    Succeed a n committed -> case run (f a) (drop n s) of
+    Succeed a s n ->
-      Succeed b m c2 -> Succeed b (n+m) (committed || c2)
+      case run' (f a) (Env overall (i+n) s (drop n cur)) of
-      Fail e b -> Fail e (committed || b)
+        Succeed b s m -> Succeed b s (n+m)
+        Fail e b -> Fail e b
     Fail e b -> Fail e b
+  fail msg = Parser $ const (Fail [msg] False)
 
-instance MonadPlus Parser where
+instance MonadPlus (Parser s) where
   mzero = Parser $ \_ -> Fail [] False
-  mplus p1 p2 = Parser $ \s -> case run p1 s of
+  mplus p1 p2 = Parser $ \env -> case run' p1 env of
-    Fail _ False -> run p2 s
+    Fail _ False -> run' p2 env
     ok -> ok

shared/src/Unison/Parsers.hs

@@ -8,6 +8,7 @@ import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Parser (Result(..), run, unsafeGetSucceed)
+import Unison.Var (Var)
 import Unison.View (DFO)
 import qualified Unison.Parser as Parser
 import qualified Data.Text as Text
@@ -20,36 +21,28 @@ import qualified Unison.Reference as R
 import qualified Unison.Var as Var
 
 type V = Symbol DFO
+type S = TypeParser.S V
 
-parseTerm :: String -> Result (Term V)
+s0 :: S
+s0 = TypeParser.s0
+
+parseTerm :: String -> Result S (Term V)
 parseTerm = parseTerm' termBuiltins typeBuiltins
 
-parseType :: String -> Result (Type V)
+parseType :: String -> Result S (Type V)
 parseType = parseType' typeBuiltins
 
-parseTerm' :: [(V, Term V)] -> [(V, Type V)] -> String -> Result (Term V)
+parseTerm' :: [(V, Term V)] -> [(V, Type V)] -> String -> Result S (Term V)
-parseTerm' termBuiltins typeBuiltins s = case run (Parser.root TermParser.term) s of
+parseTerm' termBuiltins typeBuiltins s =
-  Succeed e n b ->
+  bindBuiltins termBuiltins typeBuiltins <$> run (Parser.root TermParser.term) s s0
-    Succeed (Term.typeMap (ABT.substs typeBuiltins) (ABT.substs termBuiltins e)) n b
-  fail -> fail
 
-parseType' :: [(V, Type V)] -> String -> Result (Type V)
+bindBuiltins :: Var v => [(v, Term v)] -> [(v, Type v)] -> Term v -> Term v
-parseType' typeBuiltins s = case run (Parser.root TypeParser.type_) s of
+bindBuiltins termBuiltins typeBuiltins =
-  Succeed t n b -> Succeed (ABT.substs typeBuiltins t) n b
+   Term.typeMap (ABT.substs typeBuiltins) . ABT.substs termBuiltins
-  fail -> fail
 
-prelude = unlines
+parseType' :: [(V, Type V)] -> String -> Result S (Type V)
-  [ "let"
+parseType' typeBuiltins s =
-  , "  Index.empty : forall k v . Remote (Index k v);"
+  ABT.substs typeBuiltins <$> run (Parser.root TypeParser.type_) s s0
-  , "  Index.empty = Remote.map Index.unsafeEmpty Remote.here;"
-  , ""
-  , "  Remote.transfer : Node -> Remote Unit;"
-  , "  Remote.transfer node = Remote.at node unit"
-  , "in"
-  , ""]
-
-unsafeParseTermWithPrelude :: String -> Term V
-unsafeParseTermWithPrelude prog = unsafeParseTerm (prelude ++ prog)
 
 unsafeParseTerm :: String -> Term V
 unsafeParseTerm = unsafeGetSucceed . parseTerm
@@ -74,35 +67,26 @@ data Builtin = Builtin Text -- e.g. Builtin "()"
              | AliasFromModule Text [Text] [Text]
 
 -- aka default imports
-termBuiltins :: [(V, Term V)]
+termBuiltins :: Var v => [(v, Term v)]
 termBuiltins = (Var.named *** Term.ref) <$> (
-    [ Alias "+" "Number.plus"
+    [ Builtin "True"
-    , Alias "-" "Number.minus"
-    , Alias "*" "Number.times"
-    , Alias "/" "Number.divide"
-    , Alias ">" "Number.greaterThan"
-    , Alias "<" "Number.lessThan"
-    , Alias ">=" "Number.greaterThanOrEqual"
-    , Alias "<=" "Number.lessThanOrEqual"
-    , Alias "==" "Number.equal"
-    , Alias "if" "Boolean.if"
-    , Builtin "True"
     , Builtin "False"
     , Builtin "()"
+    , Builtin "Either.Right"
+    , Builtin "Either.Left"
+    , Builtin "Greater"
+    , Builtin "Less"
+    , Builtin "Equal"
     , Alias "unit" "()"
-    , Alias "some" "Optional.Some"
+    , Alias "Unit" "()"
-    , Alias "none" "Optional.None"
+    , Alias "Some" "Optional.Some"
-    , AliasFromModule "Vector"
+    , Alias "None" "Optional.None"
-        ["single", "prepend", "map", "fold-left", "concatenate", "append"] ["empty"]
+    , Alias "+" "Number.+"
-    , AliasFromModule "Text"
+    , Alias "-" "Number.-"
-        ["concatenate", "left", "right", "center", "justify"] []
+    , Alias "*" "Number.*"
-    , AliasFromModule "Remote"
+    , Alias "/" "Number./"
-        ["fork", "receive", "receiveAsync", "pure", "bind", "map", "channel", "send", "here", "at", "spawn"] []
+    , AliasFromModule "Vector" ["single"] []
-    , AliasFromModule "Color" ["rgba"] []
+    , AliasFromModule "Remote" ["pure", "bind", "pure", "fork"] []
-    , AliasFromModule "Symbol" ["Symbol"] []
-    , AliasFromModule "Index" ["lookup", "unsafeLookup", "insert", "unsafeInsert", "empty", "unsafeEmpty"] []
-    , AliasFromModule "Html" ["getLinks", "getHref", "getDescription"] []
-    , AliasFromModule "Http" ["getURL", "unsafeGetURL"] []
     ] >>= unpackAliases)
     where
       unpackAliases :: Builtin -> [(Text, R.Reference)]
@@ -117,26 +101,27 @@ termBuiltins = (Var.named *** Term.ref) <$> (
       aliasFromModule m sym = alias sym (Text.intercalate "." [m, sym])
       builtinInModule m sym = builtin (Text.intercalate "." [m, sym])
 
-typeBuiltins :: [(V, Type V)]
+typeBuiltins :: Var v => [(v, Type v)]
 typeBuiltins = (Var.named *** Type.lit) <$>
   [ ("Number", Type.Number)
   , builtin "Unit"
   , builtin "Boolean"
   , ("Optional", Type.Optional)
   , builtin "Either"
-  -- ???
+  , builtin "Pair"
-  , builtin "Symbol"
+  , builtin "Order"
-  , builtin "Alignment"
+  , builtin "Comparison"
-  , builtin "Color"
+  , builtin "Order.Key"
-  , builtin "Fixity"
   -- kv store
   , builtin "Index"
   -- html
-  , builtin "Link"
+  , builtin "Html.Link"
   -- distributed
   , builtin "Channel"
-  , builtin "Future"
+  , builtin "Duration"
   , builtin "Remote"
   , builtin "Node"
+  -- hashing
+  , builtin "Hash"
   ]
   where builtin t = (t, Type.Ref $ R.Builtin t)

shared/src/Unison/Remote.hs

@@ -100,8 +100,10 @@ data Local t
   | CreateChannel
   -- here : Local Node
   | Here
-  -- receiveAsync : Channel a -> Local (Local a)
+  -- sleep : Duration -> Local ()
-  | ReceiveAsync Channel Timeout
+  | Sleep Duration
+  -- receiveAsync : Channel a -> Duration -> Local (Local a)
+  | ReceiveAsync Channel Duration
   -- receive : Channel a -> Local a
   | Receive Channel
   -- send : Channel a -> a -> Local ()
@@ -121,16 +123,17 @@ instance Hashable1 Local where
     Receive c -> [tag 4, H.accumulateToken c]
     Send c t -> [tag 5, H.accumulateToken c, hashed t]
     Spawn -> [tag 6]
-    Pure t -> [tag 7, hashed t]
+    Sleep (Seconds d) -> [tag 7, H.Double d]
+    Pure t -> [tag 8, hashed t]
     where
       tag = H.Tag
       hashed1 = H.Hashed . (H.hash1 hashCycle hash)
       hashed = H.Hashed . hash
 
-newtype Timeout = Seconds { seconds :: Double } deriving (Eq,Ord,Show,Generic)
+newtype Duration = Seconds { seconds :: Double } deriving (Eq,Ord,Show,Generic)
-instance ToJSON Timeout
+instance ToJSON Duration
-instance FromJSON Timeout
+instance FromJSON Duration
-instance Hashable Timeout where
+instance Hashable Duration where
   tokens (Seconds seconds) = [H.Double seconds]
 
 
@@ -168,7 +171,10 @@ instance Hashable Node where
 instance Show Node where
   show (Node host key) = "http://" ++ Text.unpack host ++ "/" ++ Text.unpack (decodeUtf8 (Base64.encode key))
 
-newtype Channel = Channel ByteString deriving (Eq,Ord,Generic,Show)
+newtype Channel = Channel ByteString deriving (Eq,Ord,Generic)
+instance Show Channel where
+  show (Channel id) = Text.unpack (decodeUtf8 (Base64.encode id))
+
 instance ToJSON Channel where toJSON (Channel c) = toJSON (decodeUtf8 (Base64.encode c))
 
 instance FromJSON Channel where

shared/src/Unison/Term.hs

@@ -45,11 +45,13 @@ import qualified Unison.Remote as Remote
 data Literal
   = Number Double
   | Text Text
+  | If
   deriving (Eq,Ord,Generic)
 
 instance Hashable Literal where
   tokens (Number d) = [Hashable.Tag 0, Hashable.Double d]
   tokens (Text txt) = [Hashable.Tag 1, Hashable.Text txt]
+  tokens If = [Hashable.Tag 2]
 
 -- | Base functor for terms in the Unison language
 data F v a
@@ -119,6 +121,7 @@ pattern Var' v <- ABT.Var' v
 pattern Lit' l <- (ABT.out -> ABT.Tm (Lit l))
 pattern Number' n <- Lit' (Number n)
 pattern Text' s <- Lit' (Text s)
+pattern If' <- Lit' If
 pattern Blank' <- (ABT.out -> ABT.Tm Blank)
 pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r))
 pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r)))
@@ -259,6 +262,14 @@ unApps t = case go t [] of [] -> Nothing; f:args -> Just (f,args)
   go _ [] = []
   go fn args = fn:args
 
+pattern LamsNamed' vs body <- (unLams' -> Just (vs, body))
+
+unLams' :: Term v -> Maybe ([v], Term v)
+unLams' (LamNamed' v body) = case unLams' body of
+  Nothing -> Just ([v], body)
+  Just (vs, body) -> Just (v:vs, body)
+unLams' _ = Nothing
+
 dependencies' :: Ord v => Term v -> Set Reference
 dependencies' t = Set.fromList . Writer.execWriter $ ABT.visit' f t
   where f t@(Ref r) = Writer.tell [r] *> pure t
@@ -272,15 +283,6 @@ countBlanks t = Monoid.getSum . Writer.execWriter $ ABT.visit' f t
   where f Blank = Writer.tell (Monoid.Sum (1 :: Int)) *> pure Blank
         f t = pure t
 
--- | Convert all 'Ref' constructors to the corresponding term
-link :: (Applicative f, Monad f, Var v) => (Hash -> f (Term v)) -> Term v -> f (Term v)
-link env e =
-  let ds = map (\h -> (h, link env =<< env h)) (Set.toList (dependencies e))
-      sub e (h, ft) = replace <$> ft
-        where replace t = ABT.replace ((==) rt) t e
-              rt = ref (Reference.Derived h)
-  in foldM sub e ds
-
 -- | If the outermost term is a function application,
 -- perform substitution of the argument into the body
 betaReduce :: Var v => Term v -> Term v
@@ -334,6 +336,7 @@ instance (Ord v, FromJSON v) => J.FromJSON1 (F v) where parseJSON1 j = Aeson.par
 
 instance Show Literal where
   show (Text t) = show t
+  show If = "if"
   show (Number n) = case floor n of
     m | fromIntegral m == n -> show (m :: Int)
     _ -> show n

shared/src/Unison/TermParser.hs

@@ -1,4 +1,5 @@
 {-# Language OverloadedStrings #-}
+{-# Language ScopedTypeVariables #-}
 
 module Unison.TermParser where
 
@@ -7,7 +8,7 @@ import Prelude hiding (takeWhile)
 import Control.Applicative
 import Data.Char (isDigit, isAlphaNum, isSpace, isSymbol, isPunctuation)
 import Data.Foldable (asum)
-import Data.Functor (($>), void)
+import Data.Functor
 import Data.List (foldl')
 import Data.Set (Set)
 import Unison.Parser
@@ -18,6 +19,7 @@ import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Unison.ABT as ABT
 import qualified Unison.Term as Term
+import qualified Unison.Type as Type
 import qualified Unison.TypeParser as TypeParser
 import qualified Unison.Var as Var
 
@@ -31,16 +33,18 @@ operator characters (like empty? or fold-left).
 Sections / partial application of infix operators is not implemented.
 -}
 
-term :: (Var v, Show v) => Parser (Term v)
+type S = TypeParser.S
+
+term :: Var v => Parser (S v) (Term v)
 term = possiblyAnnotated term2
 
-term2 :: (Var v, Show v) => Parser (Term v)
+term2 :: Var v => Parser (S v) (Term v)
 term2 = let_ term3 <|> term3
 
-term3 ::(Var v, Show v) => Parser (Term v)
+term3 :: Var v => Parser (S v) (Term v)
-term3 = infixApp term4 <|> term4
+term3 = ifthen <|> infixApp term4 <|> term4
 
-infixApp :: Var v => Parser (Term v) -> Parser (Term v)
+infixApp :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
 infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
   where
     arg = p
@@ -49,52 +53,81 @@ infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
     g :: Ord v => Term v -> (v, Term v) -> Term v
     g lhs (op, rhs) = Term.apps (Term.var op) [lhs,rhs]
 
-term4 :: (Var v, Show v) => Parser (Term v)
+term4 :: Var v => Parser (S v) (Term v)
 term4 = prefixApp term5
 
-term5 :: (Var v, Show v) => Parser (Term v)
+term5 :: Var v => Parser (S v) (Term v)
 term5 = lam term <|> effectBlock <|> termLeaf
 
-termLeaf :: (Var v, Show v) => Parser (Term v)
+termLeaf :: Var v => Parser (S v) (Term v)
-termLeaf = asum [hashLit, prefixTerm, lit, parenthesized term, blank, vector term]
+termLeaf = asum [hashLit, prefixTerm, lit, tupleOrParenthesized term, blank, vector term]
+
+ifthen :: Var v => Parser (S v) (Term v)
+ifthen = do
+  _ <- token (string "if")
+  scope "if-then-else" . commit $ do
+    cond <- attempt term
+    _ <- token (string "then")
+    iftrue <- attempt term
+    _ <- token (string "else")
+    iffalse <- term
+    pure (Term.apps (Term.lit Term.If) [cond, iftrue, iffalse])
+
+tupleOrParenthesized :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
+tupleOrParenthesized rec =
+  parenthesized $ go <$> sepBy1 (token $ string ",") rec where
+    go [t] = t -- was just a parenthesized term
+    go terms = foldr pair unit terms -- it's a tuple literal
+    pair t1 t2 = Term.builtin "Pair" `Term.app` t1 `Term.app` t2
+    unit = Term.builtin "()"
 
 -- |
--- Remote { x := pure 23; y := at node2 23; pure 19 }
+-- do Remote x := pure 23; y := at node2 23; pure 19;;
--- Remote { action1; action2; }
+-- do Remote action1; action2;;
--- Remote { action1; x = 1 + 1; action2; }
+-- do Remote action1; x = 1 + 1; action2;;
-effectBlock :: (Var v, Show v) => Parser (Term v)
+-- do Remote
-effectBlock = do
+--   x := pure 23;
-  name <- wordyId <* token (string "{")
+--   y = 11;
-  let qualifiedPure = ABT.var' (Text.pack name `mappend` Text.pack ".pure")
+--   pure (f x);;
-      qualifiedBind = ABT.var' (Text.pack name `mappend` Text.pack ".bind")
+effectBlock :: forall v . Var v => Parser (S v) (Term v)
-  bindings <- some $ asum [Right <$> binding qualifiedPure, Left <$> action qualifiedPure]
+effectBlock = (token (string "do") *> wordyId keywords) >>= go where
-  Just result <- pure $ foldr (bind qualifiedBind) Nothing bindings
+  go name = do
-  result <$ lineErrorUnless "missing }" (token (string "}"))
+    bindings <- some $ asum [Right <$> binding, Left <$> action] <* semicolon
-  where
+    semicolon
-  bind qb = go where
+    Just result <- pure $ foldr bind Nothing bindings
-    go (Right (lhs,rhs)) (Just acc) = Just $ qb `Term.apps` [Term.lam lhs acc, rhs]
+    pure result
-    go (Right (_,_)) Nothing = Nothing
+    where
-    go (Left action) (Just acc) = Just $ qb `Term.apps` [Term.lam (ABT.v' "_") acc, action]
+    qualifiedPure, qualifiedBind :: Term v
-    go (Left action) _ = Just action
+    qualifiedPure = ABT.var' (Text.pack name `mappend` Text.pack ".pure")
-  interpretPure qp = ABT.subst (ABT.v' "pure") qp
+    qualifiedBind = ABT.var' (Text.pack name `mappend` Text.pack ".bind")
-  binding qp = scope "binding" $ do
+    bind :: (Either (Term v) (v, Term v)) -> Maybe (Term v) -> Maybe (Term v)
-    lhs <- ABT.v' . Text.pack <$> token wordyId
+    bind = go where
-    eff <- token $ (True <$ string ":=") <|> (False <$ string "=")
+      go (Right (lhs,rhs)) (Just acc) = Just $ qualifiedBind `Term.apps` [Term.lam lhs acc, rhs]
-    rhs <- term <* token (string ";")
+      go (Right (_,_)) Nothing = Nothing
-    let rhs' = if eff then interpretPure qp rhs
+      go (Left action) (Just acc) = Just $ qualifiedBind `Term.apps` [Term.lam (ABT.v' "_") acc, action]
-               else qp `Term.app` rhs
+      go (Left action) _ = Just action
-    pure (lhs, rhs')
+    interpretPure :: Term v -> Term v
-  action qp = attempt . scope "action" $ (interpretPure qp <$> term) <* token (string ";")
+    interpretPure = ABT.subst (ABT.v' "pure") qualifiedPure
+    binding :: Parser (S v) (v, Term v)
+    binding = scope "binding" $ do
+      lhs <- ABT.v' . Text.pack <$> token (wordyId keywords)
+      eff <- token $ (True <$ string ":=") <|> (False <$ string "=")
+      rhs <- commit term
+      let rhs' = if eff then interpretPure rhs
+                 else qualifiedPure `Term.app` rhs
+      pure (lhs, rhs')
+    action :: Parser (S v) (Term v)
+    action = scope "action" $ (interpretPure <$> term)
 
-text' :: Parser Literal
+text' :: Parser s Literal
 text' =
   token $ fmap (Term.Text . Text.pack) ps
   where ps = char '"' *> Unison.Parser.takeWhile "text literal" (/= '"') <* char '"'
 
-text :: Ord v => Parser (Term v)
+text :: Ord v => Parser s (Term v)
 text = Term.lit <$> text'
 
-number' :: Parser Literal
+number' :: Parser s Literal
 number' = token (f <$> digits <*> optional ((:) <$> char '.' <*> digits))
   where
     digits = nonempty (takeWhile "number" isDigit)
@@ -102,26 +135,26 @@ number' = token (f <$> digits <*> optional ((:) <$> char '.' <*> digits))
     f whole part =
       (Term.Number . read) $ maybe whole (whole++) part
 
-hashLit :: Ord v => Parser (Term v)
+hashLit :: Ord v => Parser s (Term v)
 hashLit = token (f <$> (mark *> hash))
   where
     f = Term.derived' . Text.pack
     mark = char '#'
     hash = lineErrorUnless "error parsing base64url hash" base64urlstring
 
-number :: Ord v => Parser (Term v)
+number :: Ord v => Parser (S v) (Term v)
 number = Term.lit <$> number'
 
-lit' :: Parser Literal
+lit' :: Parser s Literal
 lit' = text' <|> number'
 
-lit :: Ord v => Parser (Term v)
+lit :: Ord v => Parser (S v) (Term v)
 lit = Term.lit <$> lit'
 
-blank :: Ord v => Parser (Term v)
+blank :: Ord v => Parser (S v) (Term v)
 blank = token (char '_') $> Term.blank
 
-vector :: Ord v => Parser (Term v) -> Parser (Term v)
+vector :: Ord v => Parser (S v) (Term v) -> Parser (S v) (Term v)
 vector p = Term.vector <$> (lbracket *> elements <* rbracket)
   where
     lbracket = token (char '[')
@@ -129,109 +162,100 @@ vector p = Term.vector <$> (lbracket *> elements <* rbracket)
     comma = token (char ',')
     rbracket = lineErrorUnless "syntax error" $ token (char ']')
 
-possiblyAnnotated :: Var v => Parser (Term v) -> Parser (Term v)
+possiblyAnnotated :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
 possiblyAnnotated p = f <$> p <*> optional ann''
   where
     f t (Just y) = Term.ann t y
     f t Nothing = t
 
-ann'' :: Var v => Parser (Type v)
+ann'' :: Var v => Parser (S v) (Type v)
 ann'' = token (char ':') *> TypeParser.type_
 
 --let server = _; blah = _ in _
-let_ :: (Var v, Show v) => Parser (Term v) -> Parser (Term v)
+let_ :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
-let_ p = f <$> (let_ *> optional rec_) <*> bindings' <* in_ <*> body
+let_ p = f <$> (let_ *> optional rec_) <*> bindings'
   where
     let_ = token (string "let")
     rec_ = token (string "rec") $> ()
-    bindings' = lineErrorUnless "error parsing let bindings" (bindings p)
+    bindings' = do
-    in_ = lineErrorUnless "missing 'in' after bindings in let-expression'" $ token (string "in")
+      bs <- lineErrorUnless "error parsing let bindings" (bindings p)
-    body = lineErrorUnless "parse error in body of let-expression" p
+      body <- lineErrorUnless "parse error in body of let-expression" term
-    -- f = maybe Term.let1'
+      semicolon2
-    f :: Ord v => Maybe () -> [(v, Term v)] -> Term v -> Term v
+      pure (bs, body)
-    f Nothing bindings body = Term.let1 bindings body
+    f :: Ord v => Maybe () -> ([(v, Term v)], Term v) -> Term v
-    f (Just _) bindings body = Term.letRec bindings body
+    f Nothing (bindings, body) = Term.let1 bindings body
+    f (Just _) (bindings, body) = Term.letRec bindings body
 
-
+typedecl :: Var v => Parser (S v) (v, Type v)
-semicolon :: Parser ()
-semicolon = void $ token (char ';')
-
-infixBinding :: (Var v, Show v) => Parser (Term v) -> Parser (v, Term v)
-infixBinding p = ((,,,,) <$> optional (typedecl <* semicolon) <*> prefixVar <*> infixVar <*> prefixVar <*> bindingEqBody p) >>= f
-  where
-    f :: (Ord v, Show v) => (Maybe (v, Type v), v, v, v, Term v) -> Parser (v, Term v)
-    f (Just (opName', _), _, opName, _, _) | opName /= opName' =
-      failWith ("The type signature for ‘" ++ show opName' ++ "’ lacks an accompanying binding")
-    f (Nothing, arg1, opName, arg2, body) = pure (mkBinding opName [arg1,arg2] body)
-    f (Just (_, type'), arg1, opName, arg2, body) = pure $ (`Term.ann` type') <$> mkBinding opName [arg1,arg2] body
-
-mkBinding :: Ord v => v -> [v] -> Term v -> (v, Term v)
-mkBinding f [] body = (f, body)
-mkBinding f args body = (f, Term.lam'' args body)
-
-typedecl :: Var v => Parser (v, Type v)
 typedecl = (,) <$> prefixVar <*> ann''
 
-prefixBinding :: (Var v, Show v) => Parser (Term v) -> Parser (v, Term v)
+bindingEqBody :: Parser (S v) (Term v) -> Parser (S v) (Term v)
-prefixBinding p = ((,,,) <$> optional (typedecl <* semicolon) <*> prefixVar <*> many prefixVar <*> bindingEqBody p) >>= f -- todo
-  where
-    f :: (Ord v, Show v) => (Maybe (v, Type v), v, [v], Term v) -> Parser (v, Term v)
-    f (Just (opName, _), opName', _, _) | opName /= opName' =
-      failWith ("The type signature for ‘" ++ show opName' ++ "’ lacks an accompanying binding")
-    f (Nothing, name, args, body) = pure $ mkBinding name args body
-    f (Just (_, t), name, args, body) = pure $ (`Term.ann` t) <$> mkBinding name args body
-
-bindingEqBody :: Parser (Term v) -> Parser (Term v)
 bindingEqBody p = eq *> body
   where
     eq = token (char '=')
     body = lineErrorUnless "parse error in body of binding" p
 
--- a wordyId isn't all digits, and isn't all symbols
+infixVar :: Var v => Parser s v
-wordyId :: Parser String
+infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId keywords)
-wordyId = token $ f <$> id <*> optional ((:) <$> dot <*> wordyId)
   where
-    dot = char '.'
+    backticked = char '`' *> wordyId keywords <* token (char '`')
-    id = identifier [any (not.isDigit), any isAlphaNum, (`notElem` keywords)]
-    f id rest = maybe id (id++) rest
 
--- a symbolyId is all symbols
+prefixVar :: Var v => Parser s v
-symbolyId :: Parser String
-symbolyId = token $ identifier'
-  [notReservedChar, not . isSpace, \c -> isSymbol c || isPunctuation c]
-  [(`notElem` keywords)]
-
-infixVar :: Var v => Parser v
-infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId)
-  where
-    backticked = char '`' *> wordyId <* token (char '`')
-
-
-prefixVar :: Var v => Parser v
 prefixVar = (Var.named . Text.pack) <$> prefixOp
   where
-    prefixOp :: Parser String
+    prefixOp = wordyId keywords <|> (char '(' *> symbolyId keywords <* token (char ')')) -- no whitespace w/in parens
-    prefixOp = wordyId <|> (char '(' *> symbolyId <* token (char ')')) -- no whitespace w/in parens
 
-prefixTerm :: Var v => Parser (Term v)
+prefixTerm :: Var v => Parser (S v) (Term v)
 prefixTerm = Term.var <$> prefixVar
 
-keywords :: Set String
+keywords :: [String]
-keywords = Set.fromList ["let", "rec", "in", "->", ":", "=", "where"]
+keywords = ["alias", "do", "let", "rec", "in", "->", ":", "=", "where", "else", "then"]
 
-lam :: Var v => Parser (Term v) -> Parser (Term v)
+lam :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
 lam p = Term.lam'' <$> vars <* arrow <*> body
   where
     vars = some prefixVar
     arrow = token (string "->")
     body = p
 
-prefixApp :: Ord v => Parser (Term v) -> Parser (Term v)
+prefixApp :: Ord v => Parser (S v) (Term v) -> Parser (S v) (Term v)
 prefixApp p = f <$> some p
   where
     f (func:args) = Term.apps func args
     f [] = error "'some' shouldn't produce an empty list"
 
-bindings :: (Var v, Show v) => Parser (Term v) -> Parser [(v, Term v)]
+alias :: Var v => Parser (S v) ()
-bindings p = --many (binding term)
+alias = do
-  sepBy1 (token (char ';' <|> char '\n')) (prefixBinding p <|> infixBinding p)
+  _ <- token (string "alias")
+  scope "alias" . commit $ do
+    (fn:params) <- some (Var.named . Text.pack <$> wordyId keywords)
+    _ <- token (string "=")
+    body <- TypeParser.type_
+    semicolon
+    TypeParser.Aliases s <- get
+    let s' = (fn, apply)
+        apply args | length args <= length params = ABT.substs (params `zip` args) body
+        apply args = apply (take n args) `Type.apps` drop n args
+        n = length params
+    set (TypeParser.Aliases (s':s))
+
+bindings :: Var v => Parser (S v) (Term v) -> Parser (S v) [(v, Term v)]
+bindings p = do s0 <- get; some (binding <* semicolon) <* set s0 where
+  binding = do
+    _ <- many alias
+    typ <- optional (typedecl <* semicolon)
+    (name, args) <- ( (\arg1 op arg2 -> (op,[arg1,arg2]))
+                      <$> prefixVar <*> infixVar <*> prefixVar)
+                  <|> ((,) <$> prefixVar <*> many prefixVar)
+    body <- bindingEqBody term
+    case typ of
+      Nothing -> pure $ mkBinding name args body
+      Just (nameT, typ)
+        | name == nameT -> case mkBinding name args body of (v,body) -> pure (v, Term.ann body typ)
+        | otherwise -> fail ("The type signature for ‘" ++ show (Var.name nameT) ++ "’ lacks an accompanying binding")
+
+  mkBinding f [] body = (f, body)
+  mkBinding f args body = (f, Term.lam'' args body)
+
+moduleBindings :: Var v => Parser (S v) [(v, Term v)]
+moduleBindings = root (bindings term3)

shared/src/Unison/Type.hs

@@ -12,6 +12,7 @@ module Unison.Type where
 
 import Data.Aeson (ToJSON(..), FromJSON(..))
 import Data.Aeson.TH
+import Data.List
 import Data.Set (Set)
 import Data.Text (Text)
 import GHC.Generics
@@ -143,6 +144,9 @@ builtin = ref . Reference.Builtin
 app :: Ord v => Type v -> Type v -> Type v
 app f arg = ABT.tm (App f arg)
 
+apps :: Ord v => Type v -> [Type v] -> Type v
+apps f = foldl' app f
+
 arrow :: Ord v => Type v -> Type v -> Type v
 arrow i o = ABT.tm (Arrow i o)
 

shared/src/Unison/TypeParser.hs

@@ -1,55 +1,83 @@
+{-# Language OverloadedStrings #-}
+
 module Unison.TypeParser where
 
-import Control.Applicative ((<|>), some)
+import Control.Monad
+import Control.Applicative ((<|>), some, many)
 import Data.Char (isUpper, isLower, isAlpha)
-import Data.List (foldl1')
 import Data.Foldable (asum)
-import qualified Data.Text as Text
+import Data.Functor
-
+import Data.List
 import Unison.Parser
 import Unison.Type (Type)
 import Unison.Var (Var)
+import qualified Data.Text as Text
 import qualified Unison.Type as Type
 
--- type V = Symbol DFO
+newtype S v = Aliases [(v, [Type v] -> Type v)]
+s0 :: S v
+s0 = Aliases []
 
-type_ :: Var v => Parser (Type v)
+type_ :: Var v => Parser (S v) (Type v)
 type_ = forall type1 <|> type1
 
-typeLeaf :: Var v => Parser (Type v)
+typeLeaf :: Var v => Parser (S v) (Type v)
 typeLeaf =
   asum [ literal
-       , parenthesized type_
+       , tupleOrParenthesized type_
        , fmap (Type.v' . Text.pack) (token varName)
        ]
 
-type1 :: Var v => Parser (Type v)
+tupleOrParenthesized :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
+tupleOrParenthesized rec =
+  parenthesized $ go <$> sepBy1 (token $ string ",") rec where
+    go [t] = t
+    go types = foldr pair unit types
+    pair t1 t2 = Type.builtin "Pair" `Type.app` t1 `Type.app` t2
+    unit = Type.builtin "Unit"
+
+type1 :: Var v => Parser (S v) (Type v)
 type1 = arrow type2
 
-type2 :: Var v => Parser (Type v)
+type2 :: Var v => Parser (S v) (Type v)
 type2 = app typeLeaf
 
 -- "TypeA TypeB TypeC"
-app :: Ord v => Parser (Type v) -> Parser (Type v)
+app :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
-app rec = fmap (foldl1' Type.app) (some rec)
+app rec = get >>= \(Aliases aliases) -> do
+  (hd:tl) <- some rec
+  pure $ case hd of
+    Type.Var' v -> case lookup v aliases of
+      Nothing -> foldl' Type.app hd tl
+      Just apply -> apply tl
+    _ -> foldl' Type.app hd tl
 
-arrow :: Ord v => Parser (Type v) -> Parser (Type v)
+arrow :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
 arrow rec = foldr1 Type.arrow <$> sepBy1 (token $ string "->") rec
 
 -- "forall a b . List a -> List b -> Maybe Text"
-forall :: Var v => Parser (Type v) -> Parser (Type v)
+forall :: Var v => Parser (S v) (Type v) -> Parser (S v) (Type v)
 forall rec = do
-    _ <- token $ string "forall"
+    (void . token $ string "forall") <|> void (token (char '∀'))
     vars <- some $ token varName
     _ <- token (char '.')
     t <- rec
     pure $ Type.forall' (fmap Text.pack vars) t
 
-varName :: Parser String
+varName :: Parser s String
-varName = identifier [isLower.head, all isAlpha]
+varName = do
+  name <- wordyId keywords
+  guard (isLower . head $ name)
+  pure name
 
-typeName :: Parser String
+typeName :: Parser s String
-typeName = identifier [isUpper.head]
+typeName = do
+  name <- wordyId keywords
+  guard (isUpper . head $ name)
+  pure name
+
+keywords :: [String]
+keywords = ["forall", "∀"]
 
 -- qualifiedTypeName :: Parser String
 -- qualifiedTypeName = f <$> typeName <*> optional more
@@ -58,10 +86,10 @@ typeName = identifier [isUpper.head]
 --     f first more = maybe first (first++) more
 --     more = (:) <$> char '.' <*> qualifiedTypeName
 
-literal :: Var v => Parser (Type v)
+literal :: Var v => Parser (S v) (Type v)
-literal =
+literal = scope "literal" . token $
-  token $ asum [ Type.lit Type.Number <$ string "Number"
+  asum [ Type.lit Type.Number <$ string "Number"
-               , Type.lit Type.Text <$ string "Text"
+       , Type.lit Type.Text <$ string "Text"
-               , Type.lit Type.Vector <$ string "Vector"
+       , Type.lit Type.Vector <$ string "Vector"
-               , (Type.v' . Text.pack) <$> typeName
+       , (Type.v' . Text.pack) <$> typeName
-               ]
+       ]

shared/src/Unison/Typechecker/Context.hs

@@ -477,10 +477,11 @@ annotateLetRecBindings letrec = do
   pure $ (marker, body)
 
 -- | Infer the type of a literal
-synthLit :: Ord v => Term.Literal -> Type v
+synthLit :: Var v => Term.Literal -> Type v
-synthLit lit = Type.lit $ case lit of
+synthLit lit = case lit of
-  Term.Number _ -> Type.Number
+  Term.Number _ -> Type.lit Type.Number
-  Term.Text _ -> Type.Text
+  Term.Text _ -> Type.lit Type.Text
+  Term.If -> Type.forall' ["a"] (Type.builtin "Boolean" --> Type.v' "a" --> Type.v' "a" --> Type.v' "a")
 
 -- | Synthesize the type of the given term, updating the context in the process.
 synthesize :: Var v => Term v -> M v (Type v)
@@ -491,11 +492,18 @@ synthesize e = scope ("synth: " ++ show e) $ go e where
   go Term.Blank' = do
     v <- freshVar
     pure $ Type.forall (TypeVar.Universal v) (Type.universal v)
-  go (Term.Ann' (Term.Ref' _) t) =
+  go (Term.Ann' (Term.Ref' _) t) = case ABT.freeVars t of
-    -- innermost Ref annotation assumed to be correctly provided by `synthesizeClosed`
+    s | Set.null s ->
-    pure (ABT.vmap TypeVar.Universal t)
+      -- innermost Ref annotation assumed to be correctly provided by `synthesizeClosed`
+      pure (ABT.vmap TypeVar.Universal t)
+    s | otherwise ->
+      fail $ "type annotation contains free variables " ++ show (map Var.name (Set.toList s))
   go (Term.Ref' h) = fail $ "unannotated reference: " ++ show h
-  go (Term.Ann' e' t) = case ABT.vmap TypeVar.Universal t of t -> t <$ check e' t -- Anno
+  go (Term.Ann' e' t) = case ABT.freeVars t of
+    s | Set.null s ->
+      case ABT.vmap TypeVar.Universal t of t -> t <$ check e' t -- Anno
+    s | otherwise ->
+      fail $ "type annotation contains free variables " ++ show (map Var.name (Set.toList s))
   go (Term.Lit' l) = pure (synthLit l) -- 1I=>
   go (Term.App' f arg) = do -- ->E
     ft <- synthesize f; ctx <- getContext
@@ -594,22 +602,22 @@ remoteSignatureOf k = fromMaybe (error "unknown symbol") (Map.lookup k remoteSig
 
 remoteSignatures :: forall v . Var v => Map.Map Text.Text (Type.Type v)
 remoteSignatures = Map.fromList
-  [ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote' (v' "a")))
+  [ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote (v' "a")))
-  , ("Remote.fork", Type.forall' ["a"] (remote' (v' "a") --> remote' unitT))
+  , ("Remote.fork", Type.forall' ["a"] (remote (v' "a") --> remote unitT))
-  , ("Remote.here", remote' (Type.builtin "Node"))
+  , ("Remote.here", remote (Type.builtin "Node"))
-  , ("Remote.spawn", remote' (Type.builtin "Node"))
+  , ("Remote.spawn", remote (Type.builtin "Node"))
-  , ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote' unitT))
+  , ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote unitT))
-  , ("Remote.channel", Type.forall' ["a"] (remote' (channel (v' "a"))))
+  , ("Remote.channel", Type.forall' ["a"] (remote (channel (v' "a"))))
-  , ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote' (v' "a") --> remote' (v' "b")))
+  , ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote (v' "a") --> remote (v' "b")))
-  , ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote' (v' "b")) --> remote' (v' "a") --> remote' (v' "b")))
+  , ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote (v' "b")) --> remote (v' "a") --> remote (v' "b")))
-  , ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote' (v' "a")))
+  , ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote (v' "a")))
-  , ("Remote.receiveAsync", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote' (remote' (v' "a"))))
+  , ("Remote.receive-async", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote (remote (v' "a"))))
-  , ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote' (v' "a"))) ]
+  , ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote (v' "a"))) ]
   where
   v' = Type.v'
-  timeoutT = Type.builtin "Remote.Timeout"
+  timeoutT = Type.builtin "Duration"
   unitT = Type.builtin "Unit"
-  remote' t = Type.builtin "Remote" `Type.app` t
+  remote t = Type.builtin "Remote" `Type.app` t
   channel t = Type.builtin "Channel" `Type.app` t
 
 -- | For purposes of typechecking, we translate `[x,y,z]` to the term
@@ -634,15 +642,19 @@ synthesizeClosed synthRef term = do
   synthesizeClosedAnnotated term
 
 synthesizeClosed' :: Var v => Term v -> M v (Type v)
-synthesizeClosed' term = case runM (synthesize term) env0 of
+synthesizeClosed' term | Set.null (ABT.freeVars term) = case runM (synthesize term) env0 of
   Left err -> M $ \_ -> Left err
   Right (t,env) -> pure $ generalizeExistentials (ctx env) t
+synthesizeClosed' term =
+  fail $ "cannot synthesize term with free variables: " ++ show (map Var.name $ Set.toList (ABT.freeVars term))
 
 synthesizeClosedAnnotated :: (Monad f, Var v) => Term v -> Noted f (Type v)
-synthesizeClosedAnnotated term = do
+synthesizeClosedAnnotated term | Set.null (ABT.freeVars term) = do
   Note.fromEither $ runM (synthesize term) env0 >>= \(t,env) ->
     -- we generalize over any remaining unsolved existentials
     pure $ generalizeExistentials (ctx env) t
+synthesizeClosedAnnotated term =
+  fail $ "cannot synthesize term with free variables: " ++ show (map Var.name $ Set.toList (ABT.freeVars term))
 
 -- boring instances
 instance Applicative (M v) where

shared/src/Unison/Util/Logger.hs

@@ -14,10 +14,10 @@ module Unison.Util.Logger where
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar
-import Control.Exception (finally, try)
+import Control.Exception (bracket, try)
 import Control.Monad
 import Data.List
-import System.IO (Handle, hPutStrLn, hGetLine)
+import System.IO (Handle, hPutStrLn, hGetLine, stdout, stderr)
 import System.IO.Error (isEOFError)
 
 type Level = Int
@@ -34,12 +34,18 @@ atomic :: Logger -> IO Logger
 atomic logger = do
   lock <- newMVar ()
   pure $
-    let raw' msg = takeMVar lock >> (raw logger msg `finally` putMVar lock ())
+    let raw' msg = bracket (takeMVar lock) (\_ -> putMVar lock ()) (\_ -> raw logger msg)
     in logger { raw = raw' }
 
 toHandle :: Handle -> Logger
 toHandle h = logger (hPutStrLn h)
 
+toStandardError :: Logger
+toStandardError = toHandle stderr
+
+toStandardOut :: Logger
+toStandardOut = toHandle stdout
+
 logHandleAt :: Logger -> Level -> Handle -> IO ()
 logHandleAt logger lvl h
   | lvl > getLevel logger = pure ()

shared/tests/Suite.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import System.IO
 import Test.Tasty
 import qualified Unison.Test.Doc as Doc
 import qualified Unison.Test.Typechecker as Typechecker
@@ -13,4 +14,6 @@ tests :: TestTree
 tests = testGroup "unison" [Doc.tests, Typechecker.tests, Term.tests, TermParser.tests, TypeParser.tests, Interpreter.tests, Components.tests]
 
 main :: IO ()
-main = defaultMain tests
+main = do
+  mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr]
+  defaultMain tests

shared/tests/Unison/Test/Common.hs

@@ -1,30 +1,51 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Unison.Test.Common where
 
+import Control.Applicative
 import Control.Monad.IO.Class
+import Data.Foldable
+import Data.Text.Encoding (decodeUtf8)
+import System.IO (FilePath)
 import Unison.Symbol (Symbol)
 import Unison.Node (Node)
 import Unison.Reference (Reference)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Views (defaultSymbol)
+import qualified Data.ByteString as B
 import qualified Data.Map as Map
+import qualified Data.Text.IO as Text.IO
+import qualified Data.Text as Text
+import qualified System.FilePath as FP
 import qualified Unison.Metadata as Metadata
 import qualified Unison.Node as Node
 import qualified Unison.Node.MemNode as MemNode
 import qualified Unison.Note as Note
 import qualified Unison.Term as Term
 import qualified Unison.View as View
+import qualified Unison.Util.Logger as L
 
 type V = Symbol View.DFO
 -- A Node for testing
-type TNode = (Node IO V Reference (Type V) (Term V), Reference -> V)
+type TNode = (Node IO V Reference (Type V) (Term V), Reference -> V, [(V, Term V)])
+
+loadDeclarations :: FilePath -> Node IO V Reference (Type V) (Term V) -> IO ()
+loadDeclarations path node = do
+  -- note - when run from repl current directory is root, but when run via stack test, current
+  -- directory is the shared subdir - so we check both locations
+  txt <- decodeUtf8 <$> (B.readFile path <|> B.readFile (".." `FP.combine` path))
+  let str = Text.unpack txt
+  _ <- Note.run $ Node.declare' Term.ref str node
+  putStrLn $ "loaded file: " ++ path
 
 node :: IO TNode
 node = do
-  node <- MemNode.make
+  logger <- L.atomic (L.atInfo L.toStandardOut)
+  node <- MemNode.make logger
+  loadDeclarations "unison-src/base.u" node
   symbols <- liftIO . Note.run $
     Map.fromList . Node.references <$> Node.search node Term.blank [] 1000 (Metadata.Query "") Nothing
+  base <- Note.run $ Node.allTermsByVarName Term.ref node
   let firstName (Metadata.Names (n:_)) = n
   let lookupSymbol ref = maybe (defaultSymbol ref) (firstName . Metadata.names) (Map.lookup ref symbols)
-  pure (node, lookupSymbol)
+  pure (node, lookupSymbol, base)

shared/tests/Unison/Test/Interpreter.hs

@@ -2,7 +2,7 @@ module Unison.Test.Interpreter where
 
 import Test.Tasty
 import Test.Tasty.HUnit
-import Unison.Parsers (unsafeParseTerm)
+import qualified Unison.Parsers as P
 import qualified Unison.Node as Node
 import qualified Unison.Note as Note
 import qualified Unison.Test.Common as Common
@@ -14,28 +14,89 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
       [ t "1 + 1" "2"
       , t "1 + 1 + 1" "3"
       , t "(x -> x) 42" "42"
-      , t "let x = 2; y = 3 in x + y" "5"
+      , t "let x = 2; y = 3 ; x + y;;" "5"
-      , t "if False 0 1" "1"
+      , t "if False then 0 else 1" "1"
-      , t "if True 12 13" "12"
+      , t "if True then 12 else 13" "12"
-      , t "1 > 0" "True"
+      , t "1 >_Number 0" "True"
-      , t "1 == 1" "True"
+      , t "1 ==_Number 1" "True"
-      , t "2 == 0" "False"
+      , t "2 ==_Number 0" "False"
-      , t "1 < 2" "True"
+      , t "1 <_Number 2" "True"
-      , t "1 <= 1" "True"
+      , t "1 <=_Number 1" "True"
-      , t "1 >= 1" "True"
+      , t "1 >=_Number 1" "True"
-      , t "let rec fac n = if (n == 0) 1 (n * fac (n - 1)) in fac 5" "120"
+      , t "Comparison.fold 1 0 0 Less" "1"
-      , t "let rec ping n = if (n >= 10) n (pong (n + 1)); pong n = ping (n + 1) in ping 0"
+      , t "Comparison.fold 0 1 0 Equal" "1"
+      , t "Comparison.fold 0 0 1 Greater" "1"
+      , t "Order.compare (Order.invert <| Order.tuple2 Number.Order Number.Order) (1,2) (1,3)" "Greater"
+      , t "Order.compare (Order.invert <| Order.tuple2 Number.Order Number.Order) (2,1) (1,3)" "Less"
+      , t "Order.compare (Order.tuple2 Number.Order Order.ignore) (1,2) (1,3)" "Equal"
+      , t "Order.compare (Order.tuple2 Order.ignore Number.Order ) (2,2) (1,3)" "Less"
+      , t "True `or` False" "True"
+      , t "False `or` True" "True"
+      , t "True `or` True" "True"
+      , t "False `or` False" "False"
+      , t "True `and` True" "True"
+      , t "True `and` False" "False"
+      , t "False `and` True" "False"
+      , t "False `and` False" "False"
+      , t "not False" "True"
+      , t "not True" "False"
+      , t "let rec fac n = if n ==_Number 0 then 1 else n * fac (n - 1); fac 5;;" "120"
+      , t "let rec ping n = if n >=_Number 10 then n else pong (n + 1); pong n = ping (n + 1); ping 0;;"
           "10"
-      , t "let id x = x; g = id 42; p = id \"hi\" in g" "42"
+      , t "let id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
-      , t "let id : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" in g" "42"
+      , t "let id : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
-      , t "((let id x = x in id) : forall a . a -> a) 42" "42"
+      , t "(let id x = x; id;; : forall a . a -> a) 42" "42"
+      , t "Optional.map ((+) 1) (Some 1)" "Some 2"
+      , t "Optional.map ((+) 1) ((Some: ∀ a . a -> Optional a) 1)" "Some 2"
+      , t "Either.fold ((+) 1) ((+) 2) (Left 1)" "2"
+      , t "Either.fold ((+) 1) ((+) 2) (Right 1)" "3"
+      , t "Either.swap (Left 1)" "Either.Right 1"
+      , t "Pair.fold (x y -> x) (1, 2)" "1"
+      , t "const 41 0" "41"
+      , t "1st (1,2,3,4)" "1"
+      , t "2nd (1,2 + 1,3,4)" "3"
+      , t "identity <| (1 + 1)" "2"
+      , t "(1 + 1) |> identity" "2"
+      , t "if \"hi\" ==_Text \"hi\" then 1 else 2" "1"
+      , t "if \"hi\" <_Text \"hiya\" then 1 else 2" "1"
+      , t "if \"hi\" <=_Text \"hiya\" then 1 else 2" "1"
+      , t "if \"hiya\" >_Text \"hi\" then 1 else 2" "1"
+      , t "if \"hiya\" >=_Text \"hi\" then 1 else 2" "1"
+      , t "if \"hi\" >=_Text \"hi\" then 1 else 2" "1"
+      , t "if \"hi\" <=_Text \"hi\" then 1 else 2" "1"
+      , t "Vector.reverse [1,2,3]" "[3,2,1]"
+      , t "Vector.reverse Vector.empty" "[]"
+      , t "Vector.fold-right Vector.prepend Vector.empty [1,2,3]" "[1,2,3]"
+      , t "Vector.fold-balanced Vector.concatenate Vector.empty (Vector.map Vector.single [1,2,3,4,5])"
+          "[1,2,3,4,5]"
+      , t "Vector.fold-balanced Vector.concatenate Vector.empty [[1],[2],[3,4],[5]]"
+          "[1,2,3,4,5]"
+      , t "Vector.fold-balanced (+) 0 [1,2,3]" "6"
+      , t "Vector.dedup-adjacent (==_Number) [1,1,2,2,3,4,4,4,4,5]" "[1,2,3,4,5]"
+      , t "Vector.dedup Number.Order [1,2,1,5,4,2,4,4,3,5]" "[1,2,3,4,5]"
+      , t "Vector.histogram Number.Order [1,2,1,5,4,2,4,4,3,5]" "[(1,2),(2,2),(3,1),(4,3),(5,2)]"
+      , t "Vector.ranked-histogram Number.Order [1,2,1,5,4,2,4,4,3,5]"
+          "[(4,3),(1,2),(2,2),(5,2),(3,1)]"
+      , t "Vector.range 0 10" "[0,1,2,3,4,5,6,7,8,9]"
+      , t "Vector.range 0 0" "[]"
+      , t "Vector.fold-left (+) 0 (Vector.replicate 5 1)" "5"
+      , t "Vector.sort-by Number.Order identity [5,2,1,3,4]" "[1,2,3,4,5]"
+      , t "Vector.sort-by (Order.invert Number.Order) identity [5,2,1,3,4]" "[5,4,3,2,1]"
+      , t "Vector.bind 2nd (Vector.zip [1,2,3] [[1],[2],[3]])" "[1,2,3]"
+      , t "Vector.all? identity [True,True,True,True]" "True"
+      , t "Vector.all? identity [True,False,True,True]" "False"
+      , t "Optional.get-or 96 (Vector.at 1 [0,1,2,3,4])" "1"
+      , t "Vector.take 0 [1,2,3]" "[]"
+      , t "Vector.take 2 [1,2,3]" "[1,2]"
+      , t "Vector.drop 2 [1,2,3]" "[3]"
       ]
     t uneval eval = testCase (uneval ++ " ⟹  " ++ eval) $ do
-      (node, _) <- node
+      (node, _, builtins) <- node
-      let term = unsafeParseTerm uneval
+      -- putStrLn (show $ map fst builtins)
+      let term = P.bindBuiltins builtins [] $ P.unsafeParseTerm uneval
       _ <- Note.run $ Node.typeAt node term []
-      [(_,_,result)] <- Note.run $ Node.evaluateTerms node [([], unsafeParseTerm uneval)]
+      [(_,_,result)] <- Note.run $ Node.evaluateTerms node [([], term)]
-      assertEqual "comparing results" (unsafeParseTerm eval) result
+      assertEqual "comparing results" (P.unsafeParseTerm eval) result
   in testGroup "Interpreter" tests
 
 main = defaultMain tests

shared/tests/Unison/Test/Term.hs

@@ -32,7 +32,7 @@ hash :: TTerm -> Hash
 hash = ABT.hash
 
 atPts :: Bool -> Common.TNode -> [(Int,Int)] -> TTerm -> [(Paths.Path, Region)]
-atPts print (_,symbol) pts t = map go pts where
+atPts print (_,symbol,_) pts t = map go pts where
   go (x,y) = let p = path x y in (p, Doc.region bounds p)
   doc = Views.term symbol t
   layout = Doc.layout Doc.textWidth (Width 80) doc
@@ -40,6 +40,9 @@ atPts print (_,symbol) pts t = map go pts where
   path x y = Doc.at bounds (X (fromIntegral x), Y (fromIntegral y))
   debug b = if print then trace ("\n" ++ Doc.debugDoc doc ++ "\n\n" ++ Doc.debugBox b ++ "\n\n" ++ Doc.debugBoxp b) b else b
 
+main :: IO ()
+main = defaultMain tests
+
 tests :: TestTree
 tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term"
     [ testCase "alpha equivalence (term)" $ assertEqual "identity"
@@ -48,56 +51,56 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term"
     , testCase "hash cycles" $ assertEqual "pingpong"
        (hash pingpong1)
        (hash pingpong2)
-    , testCase "infix-rendering (1)" $ node >>= \(_,symbol) ->
+--    , testCase "infix-rendering (1)" $ node >>= \(_,symbol,_) ->
-        let t = unsafeParseTerm "Number.plus 1 1"
+--        let t = unsafeParseTerm "Number.plus 1 1"
-        in assertEqual "+"
+--        in assertEqual "+"
-          "1 + 1"
+--          "1 + 1"
-          (Doc.formatText (Width 80) (Views.term symbol t))
+--          (Doc.formatText (Width 80) (Views.term symbol t))
-    , testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol) ->
+--    , testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol,_) ->
-        let t = unsafeParseTerm "Number.plus _"
+--        let t = unsafeParseTerm "Number.plus _"
-        in assertEqual "+"
+--        in assertEqual "+"
-          "(+) _"
+--          "(+) _"
-          (Doc.formatText (Width 80) (Views.term symbol t))
+--          (Doc.formatText (Width 80) (Views.term symbol t))
-    , testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol) ->
+--    , testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol,_) ->
-        let t = unsafeParseTerm "Number.plus"
+--        let t = unsafeParseTerm "Number.plus"
-        in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
+--        in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
-    , testCase "infix-rendering (2)" $ node >>= \(_,symbol) ->
+--    , testCase "infix-rendering (2)" $ node >>= \(_,symbol,_) ->
-        do
+--        do
-          t <- pure $ unsafeParseTerm "Number.plus 1 1"
+--          t <- pure $ unsafeParseTerm "Number.plus 1 1"
-          let d = Views.term symbol t
+--          let d = Views.term symbol t
-          assertEqual "path sanity check"
+--          assertEqual "path sanity check"
-             [Paths.Fn,Paths.Arg]
+--             [Paths.Fn,Paths.Arg]
-             (head $ Doc.leafPaths d)
+--             (head $ Doc.leafPaths d)
-    , testCase "let-rendering (1)" $ node >>= \node ->
+--    , testCase "let-rendering (1)" $ node >>= \node ->
-        do
+--        do
-          -- let xy = 4223 in 42
+--          -- let xy = 4223 in 42
-          t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
+--          t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
-          [(p1,r1), (p2,_), (p3,r3), (p4,_), (p5,r5), (p6,r6)] <- pure $
+--          [(p1,r1), (p2,_), (p3,r3), (p4,_), (p5,r5), (p6,r6)] <- pure $
-            atPts False node [(0,0), (1,0), (10,0), (11,0), (5,0), (8,0)] t
+--            atPts False node [(0,0), (1,0), (10,0), (11,0), (5,0), (8,0)] t
-          assertEqual "p1" [] p1
+--          assertEqual "p1" [] p1
-          assertEqual "p2" [] p2
+--          assertEqual "p2" [] p2
-          assertEqual "r1" (rect 0 0 19 1) r1
+--          assertEqual "r1" (rect 0 0 19 1) r1
-          assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
+--          assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
-          assertEqual "r3" (rect 9 0 4 1) r3
+--          assertEqual "r3" (rect 9 0 4 1) r3
-          assertEqual "p3 == p4" p3 p4
+--          assertEqual "p3 == p4" p3 p4
-          assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
+--          assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
-          assertEqual "r5" (rect 4 0 2 1) r5
+--          assertEqual "r5" (rect 4 0 2 1) r5
-          assertEqual "p6" [Paths.Binding 0] p6
+--          assertEqual "p6" [Paths.Binding 0] p6
-          assertEqual "r6" (rect 4 0 9 1) r6
+--          assertEqual "r6" (rect 4 0 9 1) r6
-    , testCase "map lambda rendering" $ node >>= \node ->
+--    , testCase "map lambda rendering" $ node >>= \node ->
-        do
+--        do
-          -- map (x -> _) [1,2,3]
+--          -- map (x -> _) [1,2,3]
-          t <- pure $ builtin "Vector.map" `app` lam' ["x"] blank `app` vector (map num [1,2,3])
+--          t <- pure $ builtin "Vector.map" `app` lam' ["x"] blank `app` vector (map num [1,2,3])
-          [(p1,r1)] <- pure $ atPts False node [(5,0)] t
+--          [(p1,r1)] <- pure $ atPts False node [(5,0)] t
-          assertEqual "p1" [Paths.Fn, Paths.Arg] p1
+--          assertEqual "p1" [Paths.Fn, Paths.Arg] p1
-          assertEqual "r1" (rect 4 0 8 1) r1
+--          assertEqual "r1" (rect 4 0 8 1) r1
-    , testCase "operator chain rendering" $ node >>= \node ->
+--    , testCase "operator chain rendering" $ node >>= \node ->
-        do
+--        do
-          t <- pure $ unsafeParseTerm "1 + 2 + 3"
+--          t <- pure $ unsafeParseTerm "1 + 2 + 3"
-          [(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
+--          [(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
-          assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
+--          assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
-          assertEqual "r1" (rect 0 0 1 1) r1
+--          assertEqual "r1" (rect 0 0 1 1) r1
-          assertEqual "p2" [] p2
+--          assertEqual "p2" [] p2
     ]
 
 rect :: Int -> Int -> Int -> Int -> (X,Y,Width,Height)
@@ -108,15 +111,12 @@ rect x y w h =
 pingpong1 :: TTerm
 pingpong1 =
   unsafeParseTerm $
-    unlines [ "let rec ping = x -> pong (x + 1)"
+    unlines [ "let rec "
-            , "      ; pong = y -> ping (y - 1)"
+            , "  ping x = pong (x + 1);"
-            , "  in ping 1"
+            , "  pong y = ping (y - 1);"
+            , "  ping 1;;"
             ]
 
 pingpong2 :: TTerm
 pingpong2 =
-  unsafeParseTerm $
+  unsafeParseTerm $ "let rec pong1 p = ping1 (p - 1); ping1 q = pong1 (q + 1); ping1 1;;"
-    unlines [ "let rec pong1 = p -> ping1 (p - 1)"
-            , "      ; ping1 = q -> pong1 (q + 1)"
-            , "  in ping1 1"
-            ]

shared/tests/Unison/Test/TermParser.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Unison.Test.TermParser where
 
+import Data.List
 import Data.Text (Text)
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -15,11 +16,17 @@ import qualified Unison.Type as T
 -- import Test.Tasty.SmallCheck as SC
 -- import Test.Tasty.QuickCheck as QC
 
+parse' :: String -> TestTree
+parse' s = testCase ("`" ++ s ++ "`") $
+  case parseTerm s of
+    Fail e _ -> assertFailure $ "parse failure " ++ intercalate "\n" e
+    Succeed a _ _ -> pure ()
+
 parse :: (String, Term (Symbol DFO)) -> TestTree
 parse (s, expected) =
   testCase ("`" ++ s ++ "`") $
     case parseTerm s of
-      Fail _ _ -> assertFailure "parse failure"
+      Fail e _ -> assertFailure $ "parse failure " ++ intercalate "\n" e
       Succeed a _ _ -> assertEqual "mismatch" expected a
 
 parseFail :: (String,String) -> TestTree
@@ -27,16 +34,20 @@ parseFail (s, reason) =
   testCase ("`" ++ s ++ "` shouldn't parse: " ++ reason) $ assertBool "should not have parsed" $
     case parseTerm s of
       Fail {} -> True;
-      Succeed _ n _ -> n == length s;
+      Succeed _ _ n -> n == length s;
 
 tests :: TestTree
-tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> shouldFail)
+tests = testGroup "TermParser" $ (parse <$> shouldPass)
+                              ++ (parse' <$> shouldParse)
+                              ++ (parseFail <$> shouldFail)
   where
     shouldFail =
       [ ("+", "operator needs to be enclosed in parens or between arguments")
       , ("#V-fXHD3-N0E", "invalid base64url")
       , ("#V-f/XHD3-N0E", "invalid base64url")
       ]
+    shouldParse =
+      [ "do Remote n1 := Remote.spawn; n2 := Remote.spawn; let rec x = 10; Remote.pure 42;;; ;" ]
     shouldPass =
       [ ("1", one)
       , ("[1,1]", vector [one, one])
@@ -51,62 +62,63 @@ tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> should
       , ("1+1", onenone)
       , ("1+1", onenone)
       , ("1+ 1", app (var' "1+") one)
-      , ("1 +1", app one (var' "+1"))
+      -- todo: failing
+      -- , ("1 +1", app one (var' "+1"))
       , ("[1+1]", vector [onenone])
       , ("\"hello\"", hello)
       , ("_", blank)
       , ("a", a)
-      , ("Number.plus", numberplus)
+      , ("(+_Number)", numberplus)
       , ("Number.Other.plus", var' "Number.Other.plus")
       , ("f -> Remote.bind (#V-fXHD3-N0E= Remote.pure f)", remoteMap)
       , ("1:Int", ann one int)
       , ("(1:Int)", ann one int)
       , ("(1:Int) : Int", ann (ann one int) int)
-      , ("let a = 1 in a + 1", let1' [("a", one)] (apps numberplus [a, one]))
+      , ("let a = 1; a + 1;;", let1' [("a", one)] (apps numberplus [a, one]))
-      , ("let a : Int; a = 1 in a + 1", let_a_int1_in_aplus1)
+      , ("let a : Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
-      , ("let a: Int; a = 1 in a + 1", let_a_int1_in_aplus1)
+      , ("let a: Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
-      , ("let a :Int; a = 1 in a + 1", let_a_int1_in_aplus1)
+      , ("let a :Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
-      , ("let a:Int; a = 1 in a + 1", let_a_int1_in_aplus1)
+      , ("let a:Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
       , ("a b -> a + b", lam_ab_aplusb)
       , ("(a b -> a + b) : Int -> Int -> Int", ann lam_ab_aplusb intintint)
       , ("a b -> a + b : Int", lam' ["a", "b"] (ann (apps numberplus [a, b]) int))
       , ("a -> a", lam' ["a"] a)
       , ("(a -> a) : forall a . a -> a", ann (lam' ["a"] a) (T.forall' ["a"] (T.arrow a' a')))
-      , ("let f = a b -> a + b in f 1 1", f_eq_lamab_in_f11)
+      , ("let f = a b -> a + b; f 1 1;;", f_eq_lamab_in_f11)
-      , ("let f a b = a + b in f 1 1", f_eq_lamab_in_f11)
+      , ("let f a b = a + b; f 1 1;;", f_eq_lamab_in_f11)
-      , ("let f (+) b = 1 + b in f g 1", let1' [("f", lam' ["+", "b"] (apps plus [one, b]))] (apps f [g,one]))
+      , ("let f (+) b = 1 + b; f g 1;;", let1' [("f", lam' ["+", "b"] (apps plus [one, b]))] (apps f [g,one]))
-      , ("let a + b = f a b in 1 + 1", let1' [("+", lam' ["a", "b"] fab)] one_plus_one)
+      , ("let a + b = f a b; 1 + 1;;", let1' [("+", lam' ["a", "b"] fab)] one_plus_one)
-      , ("let (+) : Int -> Int -> Int; a + b = f a b in 1 + 1", plusintintint_fab_in_1plus1)
+      , ("let (+) : Int -> Int -> Int; a + b = f a b; 1 + 1;;", plusintintint_fab_in_1plus1)
-      , ("let (+) : Int -> Int -> Int; (+) a b = f a b in 1 + 1", plusintintint_fab_in_1plus1)
+      , ("let (+) : Int -> Int -> Int; (+) a b = f a b; 1 + 1;;", plusintintint_fab_in_1plus1)
-      , ("let (+) : Int -> Int -> Int; (+) a b = f a b in (+) 1 1", plusintintint_fab_in_1plus1)
+      , ("let (+) : Int -> Int -> Int; (+) a b = f a b; (+) 1 1;;", plusintintint_fab_in_1plus1)
-      , ("let f b = b + 1; a = 1 in (+) a (f 1)", let1' [("f", lam_b_bplus1), ("a", one)] (apps numberplus [a, apps f [one]]))
+      , ("let f b = b + 1; a = 1; (+) a (f 1);;", let1' [("f", lam_b_bplus1), ("a", one)] (apps numberplus [a, apps f [one]]))
       -- from Unison.Test.Term
       , ("a -> a", lam' ["a"] $ var' "a") -- id
       , ("x y -> x", lam' ["x", "y"] $ var' "x") -- const
-      , ("let rec fix = f -> f (fix f) in fix", fix) -- fix
+      , ("let rec fix = f -> f (fix f); fix;;", fix) -- fix
-      , ("let rec fix f = f (fix f) in fix", fix) -- fix
+      , ("let rec fix f = f (fix f); fix;;", fix) -- fix
       , ("1 + 2 + 3", num 1 `plus'` num 2 `plus'` num 3)
       , ("[1, 2, 1 + 1]", vector [num 1, num 2, num 1 `plus'` num 1])
-      , ("(id -> let x = id 42; y = id \"hi\" in 43) : (forall a.a) -> Number", lam' ["id"] (let1'
+      , ("(id -> let x = id 42; y = id \"hi\"; 43;;) : (forall a . a) -> Number", lam' ["id"] (let1'
         [ ("x", var' "id" `app` num 42),
           ("y", var' "id" `app` text "hi")
         ] (num 43)) `ann` (T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number))
         , ("#" ++ Text.unpack sampleHash64, derived' sampleHash64)
         , ("#" ++ Text.unpack sampleHash512, derived' sampleHash512)
-      , ("(Remote { pure 42; })", builtin "Remote.pure" `app` num 42)
+      , ("(do Remote pure 42;;)", builtin "Remote.pure" `app` num 42)
-      , ("Remote { x = 42; pure (x + 1); }",
+      , ("do Remote x = 42; pure (x + 1) ;;",
           builtin "Remote.bind" `apps` [
             lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
             builtin "Remote.pure" `app` num 42
           ]
         )
-      , ("Remote { x := pure 42; pure (x + 1); }",
+      , ("do Remote x := pure 42;  pure (x + 1) ;;",
           builtin "Remote.bind" `apps` [
             lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
             builtin "Remote.pure" `app` num 42
           ]
         )
-      , ("Remote { x := pure 42; y := pure 18; pure (x + y); }",
+      , ("do Remote\n   x := pure 42;\n   y := pure 18;\n   pure (x + y);;",
           builtin "Remote.bind" `apps` [
             lam' ["x"] (builtin "Remote.bind" `apps` [
               lam' ["y"] (builtin "Remote.pure" `app` (var' "x" `plus'` var' "y")),
@@ -128,8 +140,8 @@ tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> should
     f = var' "f"
     g = var' "g"
     plus = var' "+"
-    plus' x y = builtin "Number.plus" `app` x `app` y
+    plus' x y = builtin "Number.+" `app` x `app` y
-    numberplus = builtin "Number.plus"
+    numberplus = builtin "Number.+"
     remotepure = builtin "Remote.pure"
     remoteMap = lam' ["f"] (builtin "Remote.bind" `app` (derived' sampleHash64 `app` remotepure `app` var' "f"))
     onenone = var' "1+1"

shared/tests/Unison/Test/TypeParser.hs

@@ -37,7 +37,7 @@ tests = testGroup "TypeParser" $ fmap parseV strings
       , ("Vector Foo", T.vectorOf foo)
       , ("forall a . a -> a", forall_aa)
       , ("forall a. a -> a", forall_aa)
-      , ("(forall a.a) -> Number", T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number)
+      , ("(forall a . a) -> Number", T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number)
       ]
     a = T.v' "a"
     foo = T.v' "Foo"

shared/tests/Unison/Test/Typechecker.hs

@@ -35,7 +35,7 @@ instance Show StrongEq where show (StrongEq t) = show t
 
 env :: TNode -> TEnv IO
 env node r = do
-  (node, _) <- Note.lift node
+  (node, _, _) <- Note.lift node
   Node.typeAt node (E.ref r) mempty
 
 localsAt :: TNode -> Path -> TTerm -> IO [(V, Type V)]
@@ -45,7 +45,7 @@ localsAt node path e = Note.run $ do
 
 synthesizesAt :: TNode -> Path -> TTerm -> TType -> Assertion
 synthesizesAt node path e t = Note.run $ do
-  (node, _) <- Note.lift node
+  (node, _, _) <- Note.lift node
   t2 <- Node.typeAt node e path
   _ <- Note.fromEither (Typechecker.subtype t2 t)
   _ <- Note.fromEither (Typechecker.subtype t t2)
@@ -80,7 +80,7 @@ synthesizesAndChecks node e t =
 
 --singleTest = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typechecker"
 --  [
---   testTerm "f -> let x = (let saved = f in 42) in 1" $ \tms ->
+--   testTerm "f -> let x = (let saved = f; 42); 1" $ \tms ->
 --    testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
 --      (unsafeParseTerm tms)
 --      (unsafeParseType "forall x. x -> Number")
@@ -119,14 +119,14 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
   , testCase "synthesize/check (x y -> y)" $ synthesizesAndChecks node
       (unsafeParseTerm "x y -> y")
       (unsafeParseType "forall a b. a -> b -> b")
-  , testCase "synthesize/check (let f = (+) in f 1)" $ synthesizesAndChecks node
+  , testCase "synthesize/check (let f = (+); f 1;;)" $ synthesizesAndChecks node
-      (unsafeParseTerm "let f = (+) in f 1")
+      (unsafeParseTerm "let f = (+); f 1;;")
       (T.lit T.Number --> T.lit T.Number)
-  , testCase "synthesize/check (let blank x = _ in blank 1)" $ synthesizesAndChecks node
+  , testCase "synthesize/check (let blank x = _; blank 1;;)" $ synthesizesAndChecks node
-      (unsafeParseTerm "let blank x = _ in blank 1")
+      (unsafeParseTerm "let blank x = _; blank 1;;")
       (forall' ["a"] $ T.v' "a")
   , testCase "synthesize/check Term.fix" $ synthesizesAndChecks node
-      (unsafeParseTerm "let rec fix f = f (fix f) in fix")
+      (unsafeParseTerm "let rec fix f = f (fix f); fix;;")
       (forall' ["a"] $ (T.v' "a" --> T.v' "a") --> T.v' "a")
   , testCase "synthesize/check Term.pingpong1" $ synthesizesAndChecks node
       Term.pingpong1
@@ -137,15 +137,15 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
   , testTerm "[1, 2, 1 + 1]" $ \tms ->
     testCase ("synthesize/checkAt "++tms++"@[Index 2]") $ synthesizesAndChecksAt node
       [Paths.Index 2] (unsafeParseTerm tms) (T.lit T.Number)
-  , testTerm "let x = _ in _" $ \tms ->
+  , testTerm "let x = _; _;;" $ \tms ->
     testCase ("synthesize/checkAt ("++tms++")@[Binding 0,Body]") $ synthesizesAndChecksAt node
       [Paths.Binding 0, Paths.Body] (unsafeParseTerm tms) unconstrained
   -- fails
-  , testTerm "f -> let x = (let saved = f in 42) in 1" $ \tms ->
+  , testTerm "f -> let x = (let saved = f; 42;;); 1;;" $ \tms ->
     testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
       (unsafeParseTerm tms)
       (unsafeParseType "forall x. x -> Number")
-  , testTerm "f -> let x = (b a -> b) 42 f in 1" $ \tms ->
+  , testTerm "f -> let x = (b a -> b) 42 f; 1;;" $ \tms ->
     testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
       (unsafeParseTerm tms) (unsafeParseType "forall x. x -> Number")
   , testTerm "f x y -> (x y -> y) f _ + _" $ \tms ->
@@ -153,14 +153,14 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
       synthesizesAndChecks node
         (unsafeParseTerm tms)
         (unsafeParseType "forall a b c. a -> b -> c -> Number")
-  , testTerm "(id -> let x = id 42; y = id \"hi\" in 43) : (forall a . a -> a) -> Number" $ \tms ->
+  , testTerm "(id -> let x = id 42; y = id \"hi\"; 43;;) : (forall a . a -> a) -> Number" $ \tms ->
     testCase ("higher rank checking: " ++ tms) $
       let
         t = unsafeParseType "(forall a . a -> a) -> Number"
         tm = unsafeParseTerm tms
       in synthesizesAndChecks node tm t
   -- Let generalization not implemented yet; this test fails
-  --, testCase "let generalization: let id a = a; x = id 42; y = id 'hi' in 23" $
+  --, testCase "let generalization: let id a = a; x = id 42; y = id 'hi'; 23" $
   --    let
   --      tm = E.let1'
   --        [ ("id", E.lam' ["a"] (E.var' "a") `E.ann` T.forall' ["a"] (T.v' "a")),
@@ -174,22 +174,22 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
       [(_,xt), (_,yt)] <- localsAt node [Paths.Body, Paths.Body, Paths.Fn, Paths.Arg] tm
       assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
       assertEqual "yt unconstrainted" unconstrained (T.generalize yt)
-  , testTerm "let x = _ in _" $ \tms ->
+  , testTerm "let x = _; _;;" $ \tms ->
     testCase ("locals ("++tms++")") $ do
       let tm = unsafeParseTerm tms
       [(_,xt)] <- localsAt node [Paths.Body] tm
       [] <- localsAt node [Paths.Binding 0, Paths.Body] tm
       assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
-  , testTerm "let x = _; y = _ in _" $ \tms ->
+  , testTerm "let x = _; y = _; _;;" $ \tms ->
     testCase ("locals ("++tms++")@[Body,Body]") $ do
       let tm = unsafeParseTerm tms
       [(_,xt), (_,yt)] <- localsAt node [Paths.Body, Paths.Body] tm
       assertEqual "xt unconstrained" unconstrained (T.generalize xt)
       assertEqual "yt unconstrained" unconstrained (T.generalize yt)
-  , testTerm "let x = _; y = _ in _" $ \tms ->
+  , testTerm "let x = _; y = _; _;;" $ \tms ->
-    -- testTerm "let x = 42; y = _ in _" $ \tms ->
+    -- testTerm "let x = 42; y = _; _" $ \tms ->
-    -- testTerm "let x = 42; y = 43 in _" $ \tms ->
+    -- testTerm "let x = 42; y = 43; _" $ \tms ->
-    -- testTerm "let x = 42; y = 43 in 4224" $ \tms ->
+    -- testTerm "let x = 42; y = 43; 4224" $ \tms ->
     testCase ("locals ("++tms++")@[Body,Binding 0,Body]") $ do
       let tm = unsafeParseTerm tms
       [(_,xt)] <- localsAt node [Paths.Body, Paths.Binding 0, Paths.Body] tm

shared/tests/Unison/Test/Typechecker/Components.hs

@@ -15,30 +15,25 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
     tests =
       [
       -- simple case, no minimization done
-        t "let id x = x; g = id 42; y = id id g in y"
+        t "let id x = x; g = id 42; y = id id g; y;;"
-          "let id x = x; g = id 42; y = id id g in y"
+          "let id x = x; g = id 42; y = id id g; y;;"
       -- check that we get let generalization
-      , t "let rec id x = x; g = id 42; y = id id g in y"
+      , t "let rec id x = x; g = id 42; y = id id g; y;;"
-          "let id x = x; g = id 42; y = id id g in y"
+          "let id x = x; g = id 42; y = id id g; y;;"
       -- check that we preserve order of components as much as possible
-      , t "let rec id2 x = x; id1 x = x; id3 x = x in id3"
+      , t "let rec id2 x = x; id1 x = x; id3 x = x; id3;;"
-          "let id2 x = x; id1 x = x; id3 x = x in id3"
+          "let id2 x = x; id1 x = x; id3 x = x; id3;;"
       -- check that we reorder according to dependencies
-      , t "let rec g = id 42; y = id id g; id x = x in y"
+      , t "let rec g = id 42; y = id id g; id x = x; y;;"
-          "let id x = x; g = id 42; y = id id g in y"
+          "let id x = x; g = id 42; y = id id g; y;;"
       -- insane example, checks for: generalization, reordering,
       -- preservation of order when possible
-      , t "let rec g = id 42; y = id id g; ping x = pong x; pong x = id (ping x); id x = x in y"
+      , t "let rec g = id 42; y = id id g; ping x = pong x; pong x = id (ping x); id x = x; y;;"
-          "let id x = x; g = id 42; y = id id g in (let rec ping x = pong x; pong x = id (ping x) in y)"
+          "let id x = x; g = id 42; y = id id g ; (let rec ping x = pong x; pong x = id (ping x) ; y;;);;"
       ]
     t before after = testCase (before ++ " ⟹  " ++ after) $ do
-      (node, _) <- node
+      (node, _, _) <- node
       let term = unsafeParseTerm before
-      case term of
-        Term.LetRecNamed' bs _ ->
-          putStrLn $ "components: " ++ show (map (map fst) components)
-          where components = Components.components bs
-        _ -> pure ()
       let after' = Components.minimize' term
       _ <- Note.run $ Node.typeAt node after' []
       assertEqual "comparing results" (unsafeParseTerm after) after'

shared/unison-shared.cabal

@@ -111,7 +111,9 @@ test-suite tests
   other-modules:
   build-depends:
     base,
+    bytestring,
     containers,
+    filepath,
     tasty,
     tasty-hunit,
     tasty-smallcheck,

stack.yaml

@@ -13,3 +13,8 @@ extra-deps:
   - cacophony-0.7.0
   - cryptonite-0.17
   - unagi-chan-0.4.0.0
+
+extra-include-dirs:
+- /usr/local/include
+extra-lib-dirs:
+- /usr/local/lib

unison-src/base.u

@@ -0,0 +1,268 @@
+identity : ∀ a . a -> a;
+identity a = a;
+
+const x y = x;
+
+and-then : ∀ a b c . (a -> b) -> (b -> c) -> a -> c;
+and-then f1 f2 x = f2 (f1 x);
+
+(|>) : ∀ a b . a -> (a -> b) -> b;
+a |> f = f a;
+
+(<|) : ∀ a b . (a -> b) -> a -> b;
+f <| a = f a;
+
+flip : ∀ a b c . (a -> b -> c) -> b -> a -> c;
+flip f b a = f a b;
+
+first : ∀ a b . Pair a b -> a;
+first p = Pair.fold const p;
+
+rest : ∀ a b . Pair a b -> b;
+rest p = Pair.fold (x y -> y) p;
+
+1st = first;
+2nd = rest `and-then` first;
+3rd = rest `and-then` (rest `and-then` first);
+4th = rest `and-then` (rest `and-then` (rest `and-then` first));
+5th = rest `and-then` (rest `and-then` (rest `and-then` (rest `and-then` first)));
+
+set-1st : ∀ a a2 b . a2 -> Pair a b -> Pair a2 b;
+set-1st new-1st p = Pair new-1st (rest p);
+
+Order.compare : ∀ a . Order a -> a -> a -> Comparison;
+Order.compare o a1 a2 = Order.Key.compare (Order.key o a1) (Order.key o a2);
+
+Order.equal : ∀ a . Order a -> a -> a -> Boolean;
+Order.equal o a a2 =
+  Comparison.fold False True False (Order.compare o a a2);
+
+Order.tuple2 : ∀ a b . Order a -> Order b -> Order (a,b);
+Order.tuple2 a b = Pair.Order a (Pair.Order b Unit.Order);
+
+Order.tuple3 : ∀ a b c . Order a -> Order b -> Order c -> Order (a,b,c);
+Order.tuple3 a b c = Pair.Order a (Pair.Order b (Pair.Order c Unit.Order));
+
+Order.by-1st : ∀ a b . Order a -> Order (Pair a b);
+Order.by-1st a = Pair.Order a Order.ignore;
+
+Order.by-2nd : ∀ a b c . Order b -> Order (Pair a (Pair b c));
+Order.by-2nd b = Pair.Order Order.ignore (Pair.Order b Order.ignore);
+
+Order.by-3rd : ∀ a b c d . Order c -> Order (Pair a (Pair b (Pair c d)));
+Order.by-3rd c = Pair.Order Order.ignore (Pair.Order Order.ignore (Pair.Order c Order.ignore));
+
+Vector.bind : ∀ a b . (a -> Vector b) -> Vector a -> Vector b;
+Vector.bind f v = Vector.fold-balanced Vector.concatenate Vector.empty (Vector.map f v);
+
+Vector.pure = Vector.single;
+
+Vector.replicate : ∀ a . Number -> a -> Vector a;
+Vector.replicate n a = Vector.map (const a) (Vector.range 0 n);
+
+Vector.fold-right : ∀ a b . (a -> b -> b) -> b -> Vector a -> b;
+Vector.fold-right f z vs = Vector.fold-left (flip f) z (Vector.reverse vs);
+
+Vector.fold-balanced : ∀ a . (a -> a -> a) -> a -> Vector a -> a;
+Vector.fold-balanced plus zero vs =
+  let rec
+    go plus zero vs =
+      if Vector.size vs <=_Number 2
+      then Vector.fold-left plus zero vs
+      else (let p = Vector.halve vs;
+                go plus zero (1st p) `plus` go plus zero (2nd p);;);
+    go plus zero vs;;
+  ;
+
+Vector.fold-balanced1 : ∀ a . (a -> a -> a) -> Vector a -> Optional a;
+Vector.fold-balanced1 f v = Vector.fold-balanced (Optional.lift-or f) None (Vector.map Some v);
+
+Vector.join : ∀ a . Vector (Vector a) -> Vector a;
+Vector.join = Vector.bind identity;
+
+Vector.filter : ∀ a . (a -> Boolean) -> Vector a -> Vector a;
+Vector.filter f = Vector.bind (a -> if f a then [a] else []);
+
+Vector.all? : ∀ a . (a -> Boolean) -> Vector a -> Boolean;
+Vector.all? f vs = Vector.fold-balanced and True (Vector.map f vs);
+
+Vector.sort-by : ∀ k a . Order k -> (a -> k) -> Vector a -> Vector a;
+Vector.sort-by ok f v = Vector.sort-keyed (f `and-then` Order.key ok) v;
+
+Vector.sort : ∀ a . Order a -> Vector a -> Vector a;
+Vector.sort o = Vector.sort-by o identity;
+
+Vector.last : ∀ a . Vector a -> Optional a;
+Vector.last v = Vector.at (Vector.size v - 1) v;
+
+Vector.1st : ∀ a . Vector a -> Optional a;
+Vector.1st = Vector.at 0;
+
+Vector.dedup-adjacent : ∀ a . (a -> a -> Boolean) -> Vector a -> Vector a;
+Vector.dedup-adjacent eq v =
+  Vector.fold-balanced
+    (v1 v2 ->
+      if Optional.map2 eq (Vector.last v1) (Vector.1st v2) |> Optional.get-or False
+      then Vector.concatenate v1 (Vector.drop 1 v2)
+      else Vector.concatenate v1 v2)
+    []
+    (Vector.map Vector.pure v);
+
+Vector.drop-right : ∀ a . Number -> Vector a -> Vector a;
+Vector.drop-right n v = Vector.take (Vector.size v - n) v;
+
+Vector.take-right : ∀ a . Number -> Vector a -> Vector a;
+Vector.take-right n v = Vector.drop (Vector.size v - n) v;
+
+Vector.histogram : ∀ a . Order a -> Vector a -> Vector (a, Number);
+Vector.histogram o v = let
+  merge-bin b1 b2 = (1st b1, 2nd b1 + 2nd b2);
+  combine bin1 bin2 =
+    Optional.map2 (p1 p2 -> if Order.equal o (1st p1) (1st p2)
+                            then [merge-bin p1 p2]
+                            else [p1, p2])
+                  (Vector.last bin1) (Vector.1st bin2)
+    |> Optional.fold' (u -> Vector.concatenate bin1 bin2)
+                      (p -> Vector.join [Vector.drop-right 1 bin1, p, Vector.drop 1 bin2])
+    <| Unit;
+  Vector.fold-balanced combine [] (Vector.map (a -> Vector.pure (a, 1)) (Vector.sort o v));;
+;
+
+Vector.ranked-histogram : ∀ a . Order a -> Vector a -> Vector (a, Number);
+Vector.ranked-histogram o v =
+  Vector.histogram o v |> Vector.sort-by (Order.invert Number.Order) 2nd;
+
+Vector.sum : Vector Number -> Number;
+Vector.sum = Vector.fold-left (+) 0;
+
+Vector.dedup : ∀ a . Order a -> Vector a -> Vector a;
+Vector.dedup o v = Vector.dedup-adjacent (Order.equal o) (Vector.sort o v);
+
+Remote.map : ∀ a b . (a -> b) -> Remote a -> Remote b;
+Remote.map f = Remote.bind (f `and-then` Remote.pure);
+
+Remote.map2 : ∀ a b c . (a -> b -> c) -> Remote a -> Remote b -> Remote c;
+Remote.map2 f a b = do Remote
+  a := a;
+  b := b;
+  pure (f a b);;
+;
+
+Remote.map2' : ∀ a b c . (a -> b -> Remote c) -> Remote a -> Remote b -> Remote c;
+Remote.map2' f a b = Remote.map2 f a b |> Remote.join;
+
+Remote.join : ∀ a . Remote (Remote a) -> Remote a;
+Remote.join = Remote.bind identity;
+
+Remote.replicate : ∀ a . Number -> Remote a -> Remote (Vector a);
+Remote.replicate n r = Remote.sequence (Vector.replicate n r);
+
+Remote.unfold : ∀ s a . s -> (s -> Remote (Optional (a, s))) -> Remote (Vector a);
+Remote.unfold s f = let rec
+  go s acc = do Remote
+    ht := f s;
+    ht |> Optional.fold
+      (pure acc)
+      (ht -> go (2nd ht) (Vector.append (1st ht) acc));;
+  ;
+  go s Vector.empty;;
+;
+
+Remote.transfer : Node -> Remote Unit;
+Remote.transfer node = Remote.at node unit;
+
+Remote.race : ∀ a . Duration -> Vector (Remote a) -> Remote a;
+Remote.race timeout rs = do Remote
+  here := Remote.here;
+  c := Remote.channel;
+  result := Remote.receive-async c timeout;
+  Remote.traverse
+    (r -> Remote.fork <| do Remote a := r; Remote.transfer here; Remote.send c a;;)
+    rs;
+  result;;
+;
+
+-- Returns `None` if no response within the provided `timeout`,
+-- which cannot exceed 500 seconds
+Remote.timeout : ∀ a . Duration -> Remote a -> Remote (Optional a);
+Remote.timeout timeout r =
+  Remote.race (Duration.seconds 501) [
+    Remote.map Some r,
+    do Remote Remote.sleep timeout; pure None;;
+  ];
+
+Remote.at' : ∀ a . Node -> Remote a -> Remote a;
+Remote.at' node r = do Remote Remote.transfer node; r;;;
+
+Remote.start : ∀ a . Duration -> Remote a -> Remote (Remote a);
+Remote.start timeout r = do Remote
+  here := Remote.here;
+  c := Remote.channel;
+  result := Remote.receive-async c timeout;
+  Remote.fork (Remote.at' here (r |> Remote.bind (Remote.send c)));
+  pure result;;
+;
+
+Remote.traverse : ∀ a b . (a -> Remote b) -> Vector a -> Remote (Vector b);
+Remote.traverse f vs =
+  Vector.fold-balanced (Remote.map2 Vector.concatenate)
+                       (Remote.pure Vector.empty)
+                       (Vector.map (f `and-then` Remote.map Vector.single) vs);
+
+Remote.sequence : ∀ a . Vector (Remote a) -> Remote (Vector a);
+Remote.sequence vs =
+  Vector.fold-balanced (Remote.map2 Vector.concatenate)
+                       (Remote.pure Vector.empty)
+                       (Vector.map (Remote.map Vector.single) vs);
+
+Remote.parallel-traverse : ∀ a b . Duration -> (a -> Remote b) -> Vector a -> Remote (Vector b);
+Remote.parallel-traverse timeout f vs = do Remote
+  futures := Remote.traverse (f `and-then` Remote.start timeout) vs;
+  Remote.sequence futures;;
+;
+
+-- Run several remote computations in parallel, returning once `n` equivalent
+-- replies come back. Equivalence is based on result of `hash!`.
+Remote.quorum : ∀ a b . Duration -> Number -> (a -> Remote b) -> Vector a -> Remote b;
+Remote.quorum timeout n = _; -- todo
+
+Optional.map : ∀ a b . (a -> b) -> Optional a -> Optional b;
+Optional.map f = Optional.fold None (f `and-then` Some);
+
+Optional.bind : ∀ a b . (a -> Optional b) -> Optional a -> Optional b;
+Optional.bind f = Optional.fold None f;
+
+Optional.pure : ∀ a . a -> Optional a;
+Optional.pure = Some;
+
+Optional.get-or : ∀ a . a -> Optional a -> a;
+Optional.get-or a = Optional.fold a identity;
+
+Optional.somes : ∀ a . Vector (Optional a) -> Vector a;
+Optional.somes = Vector.bind (Optional.fold Vector.empty Vector.single);
+
+Optional.map2 : ∀ a b c . (a -> b -> c) -> Optional a -> Optional b -> Optional c;
+Optional.map2 f a b = do Optional
+  a := a;
+  b := b;
+  pure (f a b);;
+;
+
+Optional.lift-or : ∀ a . (a -> a -> a) -> Optional a -> Optional a -> Optional a;
+Optional.lift-or f = a1 a2 ->
+  a1 |> Optional.fold a2 (a1 -> Optional.fold None (a2 -> Some (f a1 a2)) a2);
+
+Optional.fold' : ∀ a b . (Unit -> b) -> (a -> b) -> Optional a -> Unit -> b;
+Optional.fold' thunk f = Optional.fold thunk (a u -> f a);
+
+Either.map : ∀ a b c . (b -> c) -> Either a b -> Either a c;
+Either.map f = Either.fold Left (f `and-then` Right);
+
+Either.pure : ∀ a b . b -> Either a b;
+Either.pure = Right;
+
+Either.bind : ∀ a b c . (b -> Either a c) -> Either a b -> Either a c;
+Either.bind = Either.fold Left;
+
+Either.swap : ∀ a b . Either a b -> Either b a;
+Either.swap e = Either.fold Right Left e;

unison-src/dindex-main.u

@@ -0,0 +1,11 @@
+
+do Remote
+  root := Remote.spawn;
+  Remote.transfer root;
+  ind := DIndex.empty;
+  nodes := Remote.replicate 10 Remote.spawn;
+  Remote.traverse (node -> Remote.at' node (DIndex.join ind)) nodes;
+  DIndex.insert "It's..." "ALIIIVE!!!!" ind;
+  -- Remote.parallel-traverse DIndex.Timeout (k -> DIndex.insert k k ind) (Vector.range 0 5);
+  r := DIndex.lookup "It's..." ind;
+  pure (Debug.watch "result" r);;

unison-src/dindex.u

@@ -0,0 +1,98 @@
+-- A distributed index, using Highest Random Weight (HRW) hashing
+-- to pick which nodes are responsible for which keys. See:
+-- https://en.wikipedia.org/wiki/Rendezvous_hashing
+
+DIndex.Replication-Factor = 1;
+DIndex.Timeout = Duration.seconds 10;
+DIndex.Max-Timeout = Duration.seconds 500;
+
+alias DIndex k v = Index Node (Index k v);
+
+DIndex.empty : ∀ k v . Remote (DIndex k v);
+DIndex.empty = Index.empty;
+
+-- Pick the nodes responsible for a key, using HRW hashing
+DIndex.nodesForKey : ∀ k v . k -> DIndex k v -> Remote (Vector Node);
+DIndex.nodesForKey k ind = do Remote
+  nodes := Index.keys ind;
+  hashes := Remote.traverse (node -> hash! (node, k)) nodes;
+  (nodes `Vector.zip` hashes)
+  |> Vector.sort-by Hash.Order 2nd
+  |> Vector.take DIndex.Replication-Factor
+  |> Vector.map 1st
+  |> pure;;
+;
+
+DIndex.lookup : ∀ k v . k -> DIndex k v -> Remote (Optional v);
+DIndex.lookup k ind = do Remote
+  nodes := DIndex.nodesForKey k ind;
+  localLookup = node -> (do Remote
+    nind := Index.lookup node ind;
+    -- on slim chance that a Node is removed from the cluster just before
+    -- we do the lookup, it gets treated like a timeout
+    Optional.fold (Remote.map (const None) (Remote.sleep DIndex.Timeout))
+                  (Index.lookup k)
+                  nind;;)
+  ;
+  -- todo: use Remote.quorum here
+  Remote.race DIndex.Timeout <| Vector.map localLookup nodes;;
+;
+
+DIndex.insert : ∀ k v . k -> v -> DIndex k v -> Remote Unit;
+DIndex.insert k v ind = do Remote
+  nodes := DIndex.nodesForKey k ind;
+  localInsert = node -> (do Remote
+    nind := Index.lookup node ind;
+    Optional.fold (Remote.map (const Unit) (Remote.sleep DIndex.Timeout))
+                  (Index.insert k v)
+                  nind;;)
+  ;
+  Remote.race DIndex.Timeout <| Vector.map localInsert nodes;;
+;
+
+DIndex.join : ∀ k v . DIndex k v -> Remote Unit;
+DIndex.join ind = do Remote
+  here := Remote.here;
+  localInd := Index.empty;
+  Index.insert here localInd ind;;
+;
+
+DIndex.indicesForKey : ∀ k v . k -> DIndex k v -> Remote (Vector (Index k v));
+DIndex.indicesForKey k ind = do Remote
+  nodes := DIndex.nodesForKey k ind;
+  indices := Remote.traverse (node -> Index.lookup node ind) nodes;
+  pure (Optional.somes indices);;
+;
+
+DIndex.rebalance : ∀ k v . k -> DIndex k v -> Remote Unit;
+DIndex.rebalance k ind = do Remote
+  indices := DIndex.indicesForKey k ind;
+  t = DIndex.Timeout;
+  results := Remote.parallel-traverse DIndex.Max-Timeout (Index.lookup k `and-then` Remote.timeout t) indices;
+  resultsHashes := Remote.traverse hash! results;
+  uh := hash! None;
+  hd = uh `Optional.get-or` Vector.at 0 resultsHashes;
+  eq = h1 h2 -> Hash.erase h1 ==_Hash Hash.erase h2;
+  if Vector.all? (eq hd) resultsHashes
+  -- all results matched, we're good
+  then pure Unit
+  -- not all results matched, reinsert
+  else (do Remote
+         ov := DIndex.lookup k ind;
+         Optional.fold (pure Unit)
+                       (v -> DIndex.insert k v ind)
+                       ov;;)
+  ;;
+;
+
+DIndex.leave : ∀ k v . Node -> DIndex k v -> Remote Unit;
+DIndex.leave node ind = do Remote
+  local-ind := Index.lookup node ind;
+  Index.delete node ind;
+  Optional.fold
+    (pure Unit)
+    (local-ind -> do Remote
+       keys := Index.keys local-ind;
+       Remote.fork <| Remote.traverse (k -> DIndex.rebalance k ind) keys;;)
+    local-ind;;
+;

unison-src/extra.u

@@ -0,0 +1,119 @@
+
+Index.empty : ∀ k v . Remote (Index k v);
+Index.empty = Remote.map Index.empty# Remote.here;
+
+Index.keys : ∀ k v . Index k v -> Remote (Vector k);
+Index.keys = Index.from-unsafe Index.keys#;
+
+Index.1st-key : ∀ k v . Index k v -> Remote (Optional k);
+Index.1st-key = Index.from-unsafe Index.1st-key#;
+
+Index.increment : ∀ k v . k -> Index k v -> Remote (Optional k);
+Index.increment k = Index.from-unsafe (Index.increment# k);
+
+Index.lookup : ∀ k v . k -> Index k v -> Remote (Optional v);
+Index.lookup k = Index.from-unsafe (Index.lookup# k);
+
+Index.lookup-or : ∀ k v . v -> k -> Index k v -> Remote v;
+Index.lookup-or v k ind =
+  Remote.map (Optional.get-or v) (Index.lookup k ind);
+
+Index.delete : ∀ k v . k -> Index k v -> Remote Unit;
+Index.delete k = Index.from-unsafe (Index.delete# k);
+
+Index.insert : ∀ k v . k -> v -> Index k v -> Remote Unit;
+Index.insert k v = Index.from-unsafe (Index.insert# k v);
+
+Index.inserts : ∀ k v . Vector (k,v) -> Index k v -> Remote Unit;
+Index.inserts vs ind = Remote.map (const Unit) <|
+  Remote.traverse (kv -> Index.insert (1st kv) (2nd kv) ind) vs;
+
+Index.from-unsafe : ∀ k v r . (Text -> r) -> Index k v -> Remote r;
+Index.from-unsafe f ind = let
+  p = Index.representation# ind;
+  Remote.map f (Remote.at (1st p) (2nd p));;
+;
+
+alias IndexedTraversal k v =
+   ( Remote (Optional k) -- first key
+   , k -> Remote (Optional v) -- lookup the value for a key
+   , k -> Remote (Optional k)); -- increment a key
+
+IndexedTraversal.1st-key : ∀ k v . IndexedTraversal k v -> Remote (Optional k);
+IndexedTraversal.1st-key t = 1st t;
+
+IndexedTraversal.lookup : ∀ k v . k -> IndexedTraversal k v -> Remote (Optional v);
+IndexedTraversal.lookup k t = 2nd t k;
+
+-- | Returns the smallest key in the traversal which is > the provided key.
+IndexedTraversal.increment : ∀ k v . k -> IndexedTraversal k v -> Remote (Optional k);
+IndexedTraversal.increment k t = 3rd t k;
+
+-- | Returns the smallest key in the traversal which is >= the provided key.
+IndexedTraversal.ceiling : ∀ k v . k -> IndexedTraversal k v -> Remote (Optional k);
+IndexedTraversal.ceiling k t =
+  IndexedTraversal.lookup k t |> Remote.bind (
+    Optional.fold (IndexedTraversal.increment k t) (const (pure <| Some k))
+  );
+
+Index.traversal : ∀ k v . Index k v -> IndexedTraversal (k, Hash k) v;
+Index.traversal ind = let
+  add-hash = Optional.map (k -> (k, hash# k));
+  ( Index.1st-key ind |> Remote.map add-hash
+  , k -> Index.lookup (1st k) ind
+  , k -> Index.increment (1st k) ind |> Remote.map add-hash
+  );;
+;
+
+IndexedTraversal.empty : ∀ k v . IndexedTraversal k v;
+IndexedTraversal.empty =
+  (Remote.pure None, const (Remote.pure None), const (Remote.pure None));
+
+IndexedTraversal.intersect : ∀ k v . Order k
+  -> IndexedTraversal k v
+  -> IndexedTraversal k v
+  -> IndexedTraversal k v;
+IndexedTraversal.intersect o t1 t2 = let rec
+  align-key k1 k2 = Optional.get-or (Remote.pure None) <| Optional.map2
+    (k1 k2 -> Order.compare o k1 k2 |> Comparison.fold
+       (IndexedTraversal.ceiling k2 t1 |> Remote.bind (k1 -> align-key k1 (Some k2)))
+       (Remote.pure (Some k1))
+       (IndexedTraversal.ceiling k1 t2 |> Remote.bind (k2 -> align-key (Some k1) k2))
+    )
+    k1 k2
+  ;
+  1st-key = Remote.map2' align-key (1st t1) (1st t2);
+  lookup k = 2nd t1 k |> Remote.bind (Optional.fold (Remote.pure None) (a -> 2nd t2 k));
+  increment k = Remote.map2' align-key (3rd t1 k) (3rd t2 k);
+  (1st-key, lookup, increment);;
+;
+
+IndexedTraversal.1st-entry : ∀ k v . IndexedTraversal k v -> Remote (Optional (k, v));
+IndexedTraversal.1st-entry t = IndexedTraversal.entry-at (1st t) t;
+
+IndexedTraversal.entry-at : ∀ k v .
+  Remote (Optional k) -> IndexedTraversal k v -> Remote (Optional (k, v));
+IndexedTraversal.entry-at k t = do Remote
+  k := k;
+  v := Optional.fold (pure None) (2nd t) k;
+  pure (Optional.map2 (k v -> (k,v)) k v);;
+;
+
+IndexedTraversal.take : ∀ k v . Number -> IndexedTraversal k v -> Remote (Vector (k,v));
+IndexedTraversal.take n t =
+  Remote.unfold (t, n) (tn -> let
+    t = 1st tn;
+    n = 2nd tn;
+    step e = (e, (set-1st (IndexedTraversal.increment (1st e) t) t, n - 1));
+    if n <=_Number 0 then Remote.pure None
+    else IndexedTraversal.1st-entry t |> Remote.map (Optional.map step);;
+  );
+
+IndexedTraversal.take-keys : ∀ k v . Number -> IndexedTraversal k v -> Remote (Vector k);
+IndexedTraversal.take-keys n t = IndexedTraversal.take n t |> Remote.map (Vector.map 1st);
+
+Http.get-url : Text -> Remote (Either Text Text);
+Http.get-url url = Remote.map Http.get-url# (Remote.pure url);
+
+hash! : ∀ a . a -> Remote (Hash a);
+hash! a = Remote.map hash# (Remote.pure a);

unison-src/fork.u

@@ -0,0 +1,5 @@
+do Remote
+  Remote.fork <| Remote.sleep (Duration.seconds 10);
+  Remote.fork <| Remote.sleep (Duration.seconds 10);
+  pure 23;;
+

unison-src/html.u

@@ -1,4 +1,4 @@
 -- run from unison root directory
 -- curl -H "Content-Type: text/plain; charset=UTF-8" --data-binary @node/tests/html.u http://localhost:8081/compute/dummynode909
 
-Http.getURL "http://unisonweb.org"
+Http.get-url "http://unisonweb.org"

unison-src/index.u

@@ -1,15 +1,15 @@
 -- run from unison root directory
 -- curl -H "Content-Type: text/plain; charset=UTF-8" --data-binary @node/tests/index.u http://localhost:8081/compute/dummynode909
 
-Remote {
+do Remote
   n1 := Remote.spawn;
   n2 := Remote.spawn;
-  ind := Remote {
+  ind := do Remote
     Remote.transfer n1;
     ind := Index.empty;
-    Index.insert "Unison" "Rulez!!!1" ind; 
+    Index.insert "Alice" "Jones" ind;
-    pure ind;
+    Index.insert "Bob" "Smith" ind;
-  };
+    pure ind;;
+  ;
   Remote.transfer n2;
-  Index.lookup "Unison" ind;
+  Index.lookup "Alice" ind;;
-}

unison-src/indexed-traversal.u

@@ -0,0 +1,13 @@
+
+do Remote
+  n := Remote.spawn;
+  Remote.transfer n;
+  ind1 := Index.empty;
+  ind2 := Index.empty;
+  Index.inserts [(1,"a"), (3,"b"), (9,"c")] ind1;
+  t1 = Index.traversal ind1;
+  Index.inserts [(3,"a"), (4,"b"), (9,"c"), (10, "d")] ind2;
+  t2 = Index.traversal ind2;
+  t3 = IndexedTraversal.intersect (Order.by-2nd Hash.Order) t1 t2;
+  vs := IndexedTraversal.take 10 t3;
+  pure (Debug.watch "result" vs);;

unison-src/pingpong.u

@@ -0,0 +1,17 @@
+-- run from unison root directory
+-- curl -H "Content-Type: text/plain; charset=UTF-8" --data-binary @unison-src/pingpong.u http://localhost:8081/compute/root
+
+do Remote
+  n1 := Remote.spawn;
+  n2 := Remote.spawn;
+  let rec
+    ping i = do Remote
+      i := Remote.at n2 (i + 1);
+      if (i >=_Number 5) (pure i) (pong i);;
+    ;
+    pong i = do Remote
+      i := Remote.at n1 (i + 1);
+      ping i;;
+    ;
+    ping 0;;
+  ;;

unison-src/race.u

@@ -0,0 +1,6 @@
+do Remote
+  r := Remote.race (Duration.seconds 15) [
+    do Remote pure (Debug.watch "race.winner1" 1);;,
+    do Remote Remote.sleep (Duration.seconds 10); pure (Debug.watch "race.winner2" 2);;
+  ];
+  pure <| Debug.watch "result" r;;

unison-src/receive-async.u

@@ -0,0 +1,8 @@
+
+do Remote
+  c := Remote.channel;
+  r := Remote.receive-async c (Duration.seconds 5);
+  Remote.fork (Remote.send c (Debug.watch "sent" 42));
+  -- Remote.send c 42; -- (Debug.watch "sent" 42);
+  r;;
+

unison-src/searchengine.u

@@ -0,0 +1,94 @@
+let
+  alias DIndex k v = Index Node (Index k v);
+  alias Set v = Index v Unit;
+  alias SearchIndex = DIndex Text (Set Text);
+  alias VisitSet = DIndex (Hash Text) Unit;
+
+  search : Number -> Vector Text -> SearchIndex
+        -> Remote (Vector Text);
+  search limit query ind = do Remote
+    url-sets := Remote.traverse (k -> DIndex.lookup k ind) query;
+    url-sets = Vector.map Index.traversal (Optional.somes url-sets);
+    zero = IndexedTraversal.empty;
+    merge = IndexedTraversal.intersect (Order.by-2nd Hash.Order);
+    urls = Optional.get-or IndexedTraversal.empty <| Vector.fold-balanced1 merge url-sets;
+    urls := IndexedTraversal.take-keys limit urls;
+    pure (Vector.map 1st urls);;
+  ;
+
+  trim-to-host : Text -> Text;
+  trim-to-host url = Optional.get-or url <| do Optional
+    host := Uri.parse-authority url;
+    scheme := Uri.parse-scheme url;
+    pure (Text.concatenate scheme ("//" `Text.concatenate` host));;
+  ;
+
+  -- | Convert url (possibly relative to parent) to an absolute url
+  resolve-url : Text -> Text -> Text;
+  resolve-url parent child =
+    if Text.take 1 child ==_Text "/" then
+      Text.concatenate (trim-to-host parent) child
+    else if (Text.take 5 child ==_Text "http:") `or` (Text.take 6 child ==_Text "https:") then
+      child
+    else parent `Text.concatenate` "/" `Text.concatenate` child
+  ;
+
+  crawl : Number -> SearchIndex -> VisitSet -> Text -> Remote Unit;
+  crawl depth ind visited url = let rec
+    insert url keyword = do Remote
+      url-set := DIndex.lookup keyword ind;
+      Optional.fold
+        (do Remote
+            url-set := Index.empty;
+            DIndex.insert keyword url-set ind;
+            insert url keyword;;)
+        (Index.insert url Unit)
+        url-set;;
+    ;
+    go depth url =
+      if depth <=_Number 0 then Remote.pure Unit
+      else do Remote
+        page := Remote.map (Debug.log "indexing url" url) (Http.get-url url);
+        page = Either.fold (err -> Debug.log "error fetching" (url, err) "") identity page;
+        page-hash := hash! page;
+        h := DIndex.lookup page-hash visited;
+        Optional.fold
+          (do Remote
+            page-text = Html.plain-text page;
+            keywords = Text.words page-text
+                    |> Vector.map Text.lowercase
+                    |> Vector.ranked-histogram Text.Order;
+            summary = Vector.drop 5 keywords |> Vector.take 100; -- hacky filter
+            keywords = summary;
+            -- rankings = Debug.watch "rs" <| Vector.map 2nd keywords;
+            -- rankings0 = Debug.watch "kw" <| Vector.map 1st keywords;
+            keywords = Vector.map 1st keywords;
+            links = Html.get-links page;
+            links = Vector.map (Html.get-href `and-then` resolve-url url) links;
+            -- insert all keywords for the page into the map
+            Remote.traverse (insert url) keywords;
+            -- mark page as visited
+            Debug.log "finished indexing" url <| DIndex.insert page-hash Unit visited;
+            -- recurse
+            Remote.traverse (go (depth - 1)) links;
+            pure Unit;;)
+          (x -> Remote.pure (Debug.log "already visited" url Unit))
+          h;;
+      ;
+    go depth url;;
+  ;
+
+  do Remote
+    n := Remote.spawn;
+    Remote.transfer n;
+    ind := DIndex.empty;
+    visited := DIndex.empty;
+    ind-nodes := Remote.replicate 3 Remote.spawn;
+    visited-nodes := Remote.replicate 3 Remote.spawn;
+    Remote.traverse (n -> Remote.at' n (DIndex.join ind)) ind-nodes;
+    Remote.traverse (n -> Remote.at' n (DIndex.join visited)) visited-nodes;
+    Remote.fork <| crawl 2 ind visited "http://unisonweb.org";
+    Remote.sleep (Duration.seconds 500);
+    results := search 10 ["design", "unison", "refactoring"] ind;
+    pure <| Debug.watch "results --- " results;;
+  ;;