unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-07-14 13:50:34 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #117 from unisonweb/topic/searchengine

Browse Source 
"Working" search engine example
This commit is contained in:
Paul Chiusano 2016-10-06 12:27:45 -04:00 committed by GitHub
commit f3c701198d
59 changed files with 2639 additions and 1161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

16
editor/src/Unison/TermSearchboxParser.hs
View File

@ -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 = takeWhile Char.isDigit
digits :: Parser () String
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 = char '\"' *> takeWhile (\c -> c /= '\"') <* optional (char '\"')
quotedString :: Parser () String
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

153
node/src/Container.hs
View File

@ -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.Process as P
import System.IO (stdout)
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 ->
let
fileBS = FBS.make' rand h "blockstore"
h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
locker _ = pure held
held = Lock (pure (Just (Lease (pure True) (pure ()))))
mkNode _ = do -- todo: actually use node params
publicKey <- Put.runPutS . serialize <$> rand
pure $ R.Node "localhost" publicKey
launchNode node = do
(Just stdin, Just stdout, Just stderr, handle) <- P.createProcess_ "node-worker" cmd
hSetBinaryMode stdin True
B.hPut stdin . Put.runPutS $ do
serialize ("ignored-private-key" :: B.ByteString)
serialize node
serialize (R.Universe "local-universe")
serialize B.empty -- no sandbox specification
hFlush stdin
let proof = "not-real-delete-proof"
pure (stdin, stdout, stderr, handle, proof)
cmd = (P.shell "stack exec worker") {
P.std_out = P.CreatePipe,
P.std_in = P.CreatePipe,
P.std_err = P.CreatePipe }
in do
fileBS <- fileBS
send <- C.make fileBS 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 = R.Node "localhost" (Put.runPutS . serialize . Base64.decodeLenient $ nodepk)
programtxt <- S.body
let programstr = Text.unpack (decodeUtf8 (LB.toStrict programtxt))
let !prog = unsafeParseTermWithPrelude programstr
let !prog' = Components.minimize' prog
liftIO . putStrLn $ "parsed " ++ show prog
liftIO . putStrLn $ "parsed' " ++ show prog'
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)))
main = do
logger <- Config.loggerTo stdout
rand <- Mux.uniqueChannel
let h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
#ifdef leveldb
putStrLn "using leveldb-based block store"
blockstore <- LDBS.make rand h "blockstore.leveldb"
#else
putStrLn "using file-based block store"
blockstore <- FBS.make' rand h "blockstore"
#endif
let !b0 = Builtin.makeBuiltins logger
let !crypto = Cryptography.noop "todo-real-public-key"
b1 <- ExtraBuiltins.make logger blockstore crypto
store <- Store.make
backend <- BasicNode.make SAH.hash store (\whnf -> b0 whnf ++ b1 whnf)
loadDeclarations logger "unison-src/base.u" backend
loadDeclarations logger "unison-src/extra.u" backend
loadDeclarations logger "unison-src/dindex.u" backend
let locker _ = pure held
held = Lock (pure (Just (Lease (pure True) (pure ()))))
mkNode _ = do -- todo: actually use node params
publicKey <- Put.runPutS . serialize <$> rand
pure $ Remote.Node "localhost" publicKey
lang :: Remote.Language SAH.TermV Hash
lang = Remote.Language localDependencies eval Term.app Term.node
(Term.builtin "()") Term.channel local unRemote Term.remote
local l = Term.remote (Remote.Step (Remote.Local l))
unRemote (Term.Distributed' (Term.Remote r)) = Just r
unRemote _ = Nothing
codestore = Remote.makeCodestore blockstore :: Remote.Codestore SAH.TermV Hash
localDependencies _ = Set.empty -- todo, compute this for real
whnf e = do -- todo: may want to have this use evaluator + codestore directly
[(_,_,e)] <- Node.evaluateTerms backend [([], e)]
pure e
eval t = Note.run (whnf t)
-- evaluator = I.eval allprimops
-- allbuiltins = b0 whnf ++ b1 whnf
-- allprimops = Map.fromList [ (r, op) | Builtin.Builtin r (Just op) _ _ <- allbuiltins ]
typecheck e = do
bindings <- Note.run $ Node.allTermsByVarName Term.ref backend
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

8
node/src/Node.hs
View File

@ -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
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
keyValueOps <- EB.make logger blockStore crypto
let makeBuiltins whnf = concat [Builtin.makeBuiltins logger whnf, keyValueOps whnf]
node <- BasicNode.make hash store' makeBuiltins
NodeServer.server 8080 node

6
node/src/Unison/Node/UnisonBlockStore.hs
View File

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

96
node/src/Unison/NodeContainer.hs
View File

@ -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 nodebytes = Put.runPutS $ S.serialize node
let send pk = case Get.runGetS S.deserialize (Mux.content pk) of
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.logHandleAt logger L.errorLevel stderr
-- read from the process as quickly as possible, buffering input in a queue
(fromNodeWrite, fromNodeRead) <- newChan
:: IO (InChan (Maybe Mux.Packet), OutChan (Maybe Mux.Packet))
let write a _ = writeChan fromNodeWrite a
reader <- Async.async $ Mux.deserializeHandle stdout B.empty write
-- now that we have a handle to the process, we write to it from the `toNodeRead` queue
L.debug logger "waking.."
(write, read, isActive, deleteProof) <- launchNode logger node
L.debug logger "awakened"
-- deregister the node when idle
_ <- Async.async $ do
STM.atomically $ do a <- isActive; when a STM.retry
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
bytes <- tryRead bytes >>= \bytes -> case bytes of
Nothing -> hFlush stdin >> force -- flush buffer whenever there's a pause
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)
pk <- readChan toNodeRead
L.debug logger $ "writing packet: " ++ show pk
write pk
-- 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
L.debug logger "worker process terminated"
removeRoute
_ <- Async.waitCatch reader
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
r <- Async.waitCatch processor
L.debug logger $ "worker process terminated with: " ++ show r
_ <- Async.waitCatch writer
L.debug logger "worker writer thread terminated"
pure ()
safely :: IO () -> IO ()

22
node/src/Unison/NodeProtocol.hs
View File

@ -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 chan a = Mux.run env . join $ Mux.requestTimed timeout chan a
insert bytes = mt (_insert p) bytes
lookup h = mt (_lookup p) h
declare series = mt (_declare p) series
delete series = mt (_delete p) series
update series h bytes = mt (_update p) (series,h,bytes)
append series h bytes = mt (_append p) (series,h,bytes)
resolve series = mt (_resolve p) series
resolves series = mt (_resolves p) series
mt :: (Serial a, Serial b) => String -> Request a b -> a -> IO b
mt msg chan a = Mux.run env . join $ Mux.requestTimed msg timeout chan a
insert bytes = mt "BlockStore.insert" (_insert p) bytes
lookup h = mt "BlockStore.lookup" (_lookup p) h
declare series = mt "BlockStore.declare" (_declare p) series
delete series = mt "BlockStore.delete" (_delete p) series
update series h bytes = mt "BlockStore.update" (_update p) (series,h,bytes)
append series h bytes = mt "BlockStore.append" (_append p) (series,h,bytes)
resolve series = mt "BlockStore.resolve" (_resolve p) series
resolves series = mt "BlockStore.resolves" (_resolves p) series
in BlockStore insert lookup declare delete update append resolve resolves

117
node/src/Unison/NodeWorker.hs
View File

@ -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.Serialize.Get (Get)
import GHC.Generics
import System.IO (stdin, hSetBinaryMode)
import Unison.BlockStore (BlockStore(..))
import Data.Bytes.Serial (Serial, serialize)
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
-> (Keypair key -> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext)
-> Get (Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
-> BlockStore h
-> IO (Remote.Language term thash, term -> IO (Either String ())))
-> IO ()
make protocol mkCrypto makeSandbox = do
logger <- L.scope "worker" <$> Config.loggerStandardError
let die msg = liftIO $ L.error logger msg >> error ""
L.info logger $ "initializing... "
hSetBinaryMode stdin True
(privateKey, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize B.empty)
(node, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
(universe, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
(sandbox, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
publicKey <- either die pure $ Get.runGetS deserialize (Remote.publicKey node)
let keypair = Keypair publicKey privateKey
L.debug logger $ "remaining bytes: " ++ show (B.length rem)
interrupt <- atomically $ newTSem 0
Mux.runStandardIO logger (Mux.seconds 5) rem (atomically $ waitTSem interrupt) $ do
=> L.Logger
-> P.Protocol term hash h thash
-> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
-> Remote.Language term thash
-> Remote.Node
-> Remote.Universe
-> (term -> IO (Either String term))
-> IO (Maybe Mux.Packet -> IO (), IO (Maybe Mux.Packet), STM Bool)
make logger protocol crypto sandbox node universe typecheck = do
logger <- pure $ L.scope "worker" logger
(env, toNode, fromNode, isActive) <- Mux.env0 logger
L.debug' logger $ do
active <- atomically isActive
pure $ "active0: " ++ show active
-- used to make sure we are listening on all channels before returning,
-- otherwise the caller could experience packet drops when sending
ok <- atomically $ newTSem 0 -- incremented once initialization done
L.debug logger "kicking off processor"
node <- processor ok env
_ <- 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"
_ <- Remote.server crypto connectionSandbox env sandbox protocol
_ <- do
server <- Remote.server crypto connectionSandbox env sandbox protocol
localEval <- 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
(destroy, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._destroyIn protocol)
destroyIn <- do
(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
cancel
Mux.send (Mux.Channel Mux.Type skHash) ()
Just sig -> do
-- cancel
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)

2
node/src/Unison/Remote/Extra.hs
View File

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

272
node/src/Unison/Runtime/ExtraBuiltins.hs
View File

@ -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
-> IO (WHNFEval -> [Builtin])
makeAPI blockStore crypto = do
make :: Eq a
=> Logger -> BlockStore a -> C.Cryptography k syk sk skp s h ByteString
-> 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"
type' = unsafeParseType "forall k v. Node -> Index k v"
in (r, Just (I.Primop 1 op), type', prefix "unsafeEmpty")
, let r = R.Builtin "Index.unsafeLookup"
op _ = fail "Index.empty# unpossible"
type' = unsafeParseType "forall k v . Node -> Index k v"
in (r, Just (I.Primop 1 op), type', prefix "Index.empty#")
, 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"
type' = unsafeParseType "forall k v. k -> Index k v -> Optional v"
in (r, Just (I.Primop 2 op), type', prefix "unsafeLookup")
, let r = R.Builtin "Index.lookup"
op [key, index] = do
Index' node tok <- whnf index
pure $
Term.builtin "Remote.map" `Term.apps` [
Term.builtin "Index.unsafeLookup" `Term.app` key,
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
]
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
op _ = fail "Index.lookup# unpossible"
type' = unsafeParseType "forall k v . k -> Text -> Optional v"
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup#")
, let r = R.Builtin "Index.delete#"
op [key, indexToken] = do
Term.Text' indexToken <- whnf indexToken
key <- whnf key
(db, cleanup) <- Note.lift . RP.acquire resourcePool . Index.textToId $ indexToken
Note.lift . flip finally cleanup $ do
_ <- atomically $ Index.delete (SAH.hash' key) db
pure unitRef
g k v index = pure $ Term.ref r `Term.app` k `Term.app` v `Term.app` index
op _ = fail "Index.unsafeInsert unpossible"
type' = unsafeParseType "forall k v. k -> v -> Index k v -> Unit"
in (r, Just (I.Primop 3 op), type', prefix "unsafeInsert")
, let r = R.Builtin "Index.insert"
op [key, value, index] = do
Index' node tok <- whnf index
pure $
Term.builtin "Remote.map" `Term.apps` [
Term.builtin "Index.unsafeInsert" `Term.apps` [key,value],
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
]
op _ = fail "Index.insert unpossible"
type' = unsafeParseType "forall k v. k -> v -> Index k v -> Remote Unit"
in (r, Just (I.Primop 3 op), type', prefix "insert")
, let r = R.Builtin "Html.getLinks"
op _ = fail "Index.delete# unpossible"
type' = unsafeParseType "forall k . k -> Text -> Unit"
in (r, Just (I.Primop 2 op), type', prefix "Index.delete#")
, let r = R.Builtin "Index.insert#"
op [k, v, index] = do
k <- whnf k
v <- whnf v
Term.Text' indexToken <- whnf index
Note.lift $ do
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ indexToken
flip finally cleanup $ atomically
(Index.insert (SAH.hash' k) (SAH.serializeTerm k, SAH.serializeTerm v) db)
>>= atomically
pure unitRef
op _ = fail "Index.insert# unpossible"
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"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Link", prefix "getLinks")
, let r = R.Builtin "Html.getHref"
op _ = fail "Html.get-links unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Html.Link", prefix "Html.get-links")
, 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"
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getHref")
, let r = R.Builtin "Html.getDescription"
op _ = fail "Html.get-href unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-href")
, 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"
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getDescription")
, let r = R.Builtin "Http.unsafeGetURL"
op _ = fail "Html.get-description unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-description")
-- 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"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "unsafeGetURL")
, let r = R.Builtin "Http.getURL"
op [url] = pure $ Term.builtin "Remote.pure" `Term.app`
(Term.builtin "Http.unsafeGetURL" `Term.app` url)
op _ = fail "Http.getURL unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "getURL")
op _ = fail "Http.get-url# unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.get-url#")
, let r = R.Builtin "Uri.parse-scheme"
op [Term.Text' url] = pure $ case URI.parseURI (Text.unpack url) of
Nothing -> none
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"

16
node/src/Unison/Runtime/Html.hs
View File

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

14
node/src/Unison/Runtime/Index.hs
View File

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

266
node/src/Unison/Runtime/Multiplex.hs
View File

@ -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' micros (send' req) replyTo a
requestTimedVia msg micros 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' micros req a = do
requestTimed' :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> STM a -> Multiplex (Multiplex b)
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 micros req a = do
requestTimed :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> a -> Multiplex (Multiplex b)
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
pure $ receive <* liftIO (C.killThread watchdog) <* cancel
run env (cancel $ "requestTimed timeout " ++ msg)
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
responseCiphertext <- receiveTimed micros (Channel Type bs)
encryptedRequestTimedVia msg (_,decrypt) micros send replyTo@(Channel _ bs) a = do
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 _ key) = do
(_,Callbacks cbs cba,_,_) <- ask
receiveCancellable' :: Channel a
-> Multiplex (Multiplex B.ByteString, String -> Multiplex ())
receiveCancellable' chan@(Channel _ key) = do
(_,Callbacks cbs _,_,_,_) <- ask
result <- liftIO newEmptyMVar
liftIO . atomically $ M.insert (putMVar result . Right) key cbs
liftIO $ bumpActivity' cba
cancel <- pure $ do
liftIO . atomically $ M.insert (void . tryPutMVar result . Right) key cbs
cancel <- pure $ \reason -> do
liftIO . atomically $ M.delete key cbs
liftIO $ putMVar result (Left "cancelled")
force <- pure . liftIO $ do
bytes <- takeMVar result
bytes <- either fail pure bytes
either fail pure $ Get.runGetS deserialize bytes
liftIO . void $ tryPutMVar result (Left $ "Mux.cancelled: " ++ reason)
force <- pure . scope (show chan) . scope "receiveCancellable" $ do
info "awaiting result"
bytes <- liftIO $ takeMVar result
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)
receiveTimed micros chan = do
(force, cancel) <- receiveCancellable chan
receiveCancellable :: Serial a => Channel a -> Multiplex (Multiplex a, String -> Multiplex ())
receiveCancellable chan@(Channel _ key) = f <$> receiveCancellable' chan where
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
pure $ force <* liftIO (C.killThread watchdog) <* cancel
run env (cancel $ "receiveTimed timeout during " ++ msg)
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
(_, Callbacks cbs cba, _, _) <- ask
subscribe (Channel _ key) = scope "subscribe" $ do
(_, 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
bytes <- atomically $ readTQueue q
either fail pure $ Get.runGetS deserialize bytes
force <- pure $ do
bytes <- liftIO . atomically $ readTQueue q
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

47
node/src/Unison/Runtime/Remote.hs
View File

@ -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.fork (handle crypto allow env lang p r) $> unit lang
Mux.info $ "runLocal Fork"
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
Mux.debug $ "runLocal Send " ++ show cid
runLocal (Send c@(Channel cid) a) = do
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.receiveTimed (floor $ seconds * 1000 * 1000) ((Mux.Channel Mux.Type cid) :: Mux.Channel (Maybe B.ByteString))
pure (remote lang (Step (Local (Receive chan))))
runLocal (Receive (Channel cid)) = do
Mux.debug $ "runLocal Receive " ++ show cid
(recv,_) <- Mux.receiveCancellable (Mux.Channel Mux.Type cid)
bytes <- recv
Mux.debug $ "runLocal ReceiveAsync " ++ show (seconds, chan)
forceChan <- Mux.channel
Mux.debug $ "ReceiveAsync force channel " ++ show forceChan
let micros = floor $ seconds * 1000 * 1000
force <- Mux.receiveTimed' ("receiveAsync on " ++ show chan)
micros ((Mux.Channel Mux.Type cid) :: Mux.Channel B.ByteString)
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 $

56
node/src/Worker.hs
View File

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

25
node/tests/Unison/Test/Html.hs
View File

@ -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 = do
unisonEvaluate :: (TestNode, String -> TermV) -> Assertion
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
getDescription = Term.ref (R.Builtin "Html.getDescription") `Term.app` linkTerm
getLink = Term.ref (R.Builtin "Html.get-href") `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)

41
node/tests/Unison/Test/NodeUtil.hs
View File

@ -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
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
BasicNode.make hash store' makeBuiltins
-- store' <- FS.make "blockstore.file"
putStrLn "created Node store..., building extra builtins"
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)

5
node/tests/Unison/Test/SerializationAndHashing.hs
View File

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

14
node/tests/pingpong.u
View File

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

108
node/unison-node.cabal
View File

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

18
shared/src/Unison/ABT.hs
View File

@ -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
match (Var' v') = v == v'
match _ = False
subst v r t2@(Term fvs ann body)
| Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped
| 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)

100
shared/src/Unison/Eval/Interpreter.hs
View File

@ -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 (E.Lam' _) [] = pure Nothing
reduce (E.Lam' f) (arg1:args) =
let r = ABT.bind f arg1
in pure $ Just (foldl E.app r args)
reduce (E.Ref' h) args = case M.lookup h env of
Nothing -> 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
reduce (E.App' f x) args = reduce f (x:args)
reduce (E.Let1' binding body) xs = reduce (ABT.bind body binding) xs
reduce _ _ = pure Nothing
reduce resolveRef (E.Ann' e _) args = reduce resolveRef e args
reduce resolveRef (E.App' f x) args = do
x <- whnf resolveRef x
reduce resolveRef f (x:args)
reduce resolveRef (E.Let1' binding body) xs = do
binding <- whnf resolveRef binding
reduce resolveRef (ABT.bind body binding) xs
reduce resolveRef f args = do
f <- whnf resolveRef f
case f of
E.If' -> case take 3 args of
[cond,t,f] -> do
cond <- whnf resolveRef cond
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.App' f x -> do
f' <- E.link resolveRef f
e' <- reduce f' [x]
E.Apps' f xs -> do
e' <- reduce resolveRef f xs
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.App' (E.LetRecNamed' bs body) x -> whnf resolveRef (E.letRec bs (body `E.app` x))
E.App' (E.Let1Named' v b body) x -> whnf resolveRef (E.let1 [(v,b)] (body `E.app` x))
E.App' f x -> do
f' <- E.link resolveRef f
e' <- reduce f' [x]
maybe (pure e) (whnf resolveRef) e'
E.Let1' binding body -> whnf resolveRef (ABT.bind body binding)
E.LetRecNamed' bs body -> whnf resolveRef (ABT.substs substs body) where
E.Apps' E.If' (cond:t:f:tl) -> do
cond <- whnf resolveRef cond
case cond of
E.Builtin' b | Text.head b == 'F' -> whnf resolveRef f >>= \f -> (`E.apps` tl) <$> whnf resolveRef f
| otherwise -> whnf resolveRef t >>= \t -> (`E.apps` tl) <$> whnf resolveRef t
_ -> pure e
E.Apps' f xs -> do
xs <- traverse (whnf resolveRef) xs
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
where substs' = [ (v', ABT.subst v (E.letRec bs (E.var v)) b) | (v',b) <- bs ]
substs = [ (v, expandBinding v b) | (v,b) <- bs ]
expandBinding v body = E.letRec bs body
E.Vector' es -> E.vector' <$> traverse (whnf resolveRef) es
_ -> pure e

17
shared/src/Unison/Metadata.hs
View File

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

62
shared/src/Unison/Node.hs
View File

@ -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
Store.writeMetadata store r md
Store.annotateTerm store r t
new <- (False <$ Store.readTerm store h) <|> pure True
md0 <- (Just <$> Store.readMetadata store r) <|> pure Nothing
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

28
shared/src/Unison/Node/BasicNode.hs
View File

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

458
shared/src/Unison/Node/Builtin.hs
View File

@ -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 whnf =
makeBuiltins :: Logger -> WHNFEval -> [Builtin]
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"
True -> Term.builtin "True"
False -> false
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"
in (r, strict r 4, unsafeParseType "Number -> Number -> Number -> Number -> Color", prefix "rgba")
-- debugging printlns
, 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";
op [cond,t,f] = do
cond <- whnf cond
case cond of
Term.Builtin' tf -> case Text.head tf of
'T' -> whnf t
'F' -> whnf f
_ -> error "unpossible"
_ -> error "unpossible"
, let r = R.Builtin "Boolean.and";
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 -> false
| otherwise -> if Text.head b1 == 'T' then true else false
op _ = error "unpossible"
typ = "forall a . Boolean -> a -> a -> a"
in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "if")
typ = "Boolean -> Boolean -> Boolean"
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
, let r = R.Builtin "Number.plus"
-- Number
, 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"
in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 ">")
, let r = R.Builtin "Number.lessThan"
in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "<")
, let r = R.Builtin "Number.greaterThanOrEqual"
in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 ">=")
, let r = R.Builtin "Number.lessThanOrEqual"
in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "<=")
, let r = R.Builtin "Number.equal"
in (r, Just (numericCompare (Term.ref r) (==)), numCompareTyp, opl 3 "==")
, let r = R.Builtin "Number.>"
in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 "Number.>")
, let r = R.Builtin "Number.<"
in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "Number.<")
, let r = R.Builtin "Number.>="
in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 "Number.>=")
, let r = R.Builtin "Number.<="
in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "Number.<=")
, let r = R.Builtin "Number.=="
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")
, let r = R.Builtin "Remote.receiveAsync"
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "Remote.map")
, 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")
, let r = R.Builtin "Symbol.Symbol"
in (r, Nothing, unsafeParseType "Text -> Fixity -> Number -> Symbol", prefix "Symbol")
in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.fork", prefix "Remote.fork")
-- Text
, let r = R.Builtin "Text.concatenate"
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
, let r = R.Builtin "Text.left"
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
, let r = R.Builtin "Text.right"
in (r, Nothing, alignmentT, prefixes ["right", "Text"])
, let r = R.Builtin "Text.center"
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
, let r = R.Builtin "Text.justify"
in (r, Nothing, alignmentT, prefixes ["justify", "Text"])
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefix "Text.concatenate")
, let r = R.Builtin "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.<="
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.>="
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

9
shared/src/Unison/Node/MemNode.hs
View File

@ -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 = do
make :: Logger -> IO (Node IO V Reference (Type V) (Term V))
make logger = do
store <- MemStore.make :: IO (Store IO V)
BasicNode.make hash store Builtin.makeBuiltins
BasicNode.make hash store (Builtin.makeBuiltins logger)

12
shared/src/Unison/Note.hs
View File

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

222
shared/src/Unison/Parser.hs
View File

@ -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
root p = many (whitespace1 <|> haskellLineComment) *> (p <* eof)
newtype Parser s a = Parser { run' :: Env s -> Result s a }
eof :: Parser ()
eof = Parser $ \s -> case s of
[] -> Succeed () 0 False
_ -> Fail [Prelude.takeWhile (/= '\n') s, "expected eof, got"] False
root :: Parser s a -> Parser s a
root p = ignored *> (p <* (optional semicolon <* eof))
attempt :: Parser a -> Parser a
attempt p = Parser $ \s -> case run p s of
semicolon :: Parser s ()
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
unsafeRun p s = case toEither $ run p s of
run :: Parser s a -> String -> s -> Result s a
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 s = Parser $ \input ->
if s `isPrefixOf` input then Succeed s (length s) False
else Fail ["expected '" ++ s ++ "', got " ++ takeLine input] False
string :: String -> Parser s String
string s = Parser $ \env ->
if s `isPrefixOf` (currentInput env) then Succeed s (state env) (length s)
else Fail ["expected " ++ s ++ ", got " ++ takeLine (currentInput env)] False
takeLine :: String -> String
takeLine = Prelude.takeWhile (/= '\n')
char :: Char -> Parser Char
char c = Parser $ \input ->
if listToMaybe input == Just c then Succeed c 1 False
else Fail [] False
char :: Char -> Parser s Char
char c = Parser $ \env ->
if listToMaybe (currentInput env) == Just c then Succeed c (state env) 1
else Fail ["expected " ++ show c ++ ", got " ++ takeLine (currentInput env)] False
one :: (Char -> Bool) -> Parser Char
one f = Parser $ \s -> case s of
(h:_) | f h -> Succeed h 1 False
one :: (Char -> Bool) -> Parser s Char
one f = Parser $ \env -> case (currentInput env) of
(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
token p = p <* many (whitespace1 <|> haskellLineComment)
-- a wordyId isn't all digits, isn't all symbols, and isn't a symbolyId
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 s p = commitFail $ Parser $ \input -> case run p input of
Fail e b -> Fail (s:m:e) b
where m = "near \'" ++ Prelude.takeWhile (/= '\n') input ++ "\'"
ok -> ok
lineErrorUnless :: String -> Parser s a -> Parser s a
lineErrorUnless s = commit . scope s
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 msg f = scope msg . Parser $ \s ->
let hd = Prelude.takeWhile f s
in Succeed hd (length hd) False
takeWhile :: String -> (Char -> Bool) -> Parser s String
takeWhile msg f = scope msg . Parser $ \(Env _ _ s cur) ->
let hd = Prelude.takeWhile f cur
in Succeed hd s (length hd)
takeWhile1 :: String -> (Char -> Bool) -> Parser String
takeWhile1 msg f = scope msg . Parser $ \s ->
let hd = Prelude.takeWhile f s
in if null hd then Fail ["takeWhile1 empty: " ++ take 20 s] False
else Succeed hd (length hd) False
takeWhile1 :: String -> (Char -> Bool) -> Parser s String
takeWhile1 msg f = scope msg . Parser $ \(Env _ _ s cur) ->
let hd = Prelude.takeWhile f cur
in if null hd then Fail [] 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 p = Parser $ \s -> case run p s of
Succeed _ 0 b -> Fail [] b
nonempty :: Parser s a -> Parser s a
nonempty p = Parser $ \s -> case run' p s of
Succeed _ _ 0 -> Fail [] False
ok -> ok
scope :: String -> Parser a -> Parser a
scope s p = Parser $ \input -> case run p input of
Fail e b -> Fail (s:e) b
scope :: String -> Parser s a -> Parser s a
scope s p = Parser $ \env -> case run' p env of
Fail e b -> Fail (currentLine' env : s:e) b
ok -> ok
commitSuccess :: Parser a -> Parser a
commitSuccess 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
commit :: Parser s a -> Parser s a
commit 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 ()
commit' = commitSuccess (pure ())
failWith :: String -> Parser a
failWith error = Parser . const $ Fail [error] False
sepBy :: Parser a -> Parser b -> Parser [b]
sepBy :: Parser s a -> Parser s b -> Parser s [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
= Fail [String] Bool
| Succeed a Int Bool
deriving (Show)
data Result s a
= Fail [String] !Bool
| Succeed a s !Int
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
return a = Parser $ \_ -> Succeed a 0 False
Parser p >>= f = Parser $ \s -> case p s of
Succeed a n committed -> case run (f a) (drop n s) of
Succeed b m c2 -> Succeed b (n+m) (committed || c2)
Fail e b -> Fail e (committed || b)
instance Monad (Parser s) where
return a = Parser $ \env -> Succeed a (state env) 0
Parser p >>= f = Parser $ \env@(Env overall i s cur) -> case p env of
Succeed a s n ->
case run' (f a) (Env overall (i+n) s (drop n cur)) of
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
Fail _ False -> run p2 s
mplus p1 p2 = Parser $ \env -> case run' p1 env of
Fail _ False -> run' p2 env
ok -> ok

97
shared/src/Unison/Parsers.hs
View File

@ -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' termBuiltins typeBuiltins s = case run (Parser.root TermParser.term) s of
Succeed e n b ->
Succeed (Term.typeMap (ABT.substs typeBuiltins) (ABT.substs termBuiltins e)) n b
fail -> fail
parseTerm' :: [(V, Term V)] -> [(V, Type V)] -> String -> Result S (Term V)
parseTerm' termBuiltins typeBuiltins s =
bindBuiltins termBuiltins typeBuiltins <$> run (Parser.root TermParser.term) s s0
parseType' :: [(V, Type V)] -> String -> Result (Type V)
parseType' typeBuiltins s = case run (Parser.root TypeParser.type_) s of
Succeed t n b -> Succeed (ABT.substs typeBuiltins t) n b
fail -> fail
bindBuiltins :: Var v => [(v, Term v)] -> [(v, Type v)] -> Term v -> Term v
bindBuiltins termBuiltins typeBuiltins =
Term.typeMap (ABT.substs typeBuiltins) . ABT.substs termBuiltins
prelude = unlines
[ "let"
, " Index.empty : forall k v . Remote (Index k v);"
, " 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)
parseType' :: [(V, Type V)] -> String -> Result S (Type V)
parseType' typeBuiltins s =
ABT.substs typeBuiltins <$> run (Parser.root TypeParser.type_) s s0
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"
, 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 "True"
, Builtin "False"
, Builtin "()"
, Builtin "Either.Right"
, Builtin "Either.Left"
, Builtin "Greater"
, Builtin "Less"
, Builtin "Equal"
, Alias "unit" "()"
, Alias "some" "Optional.Some"
, Alias "none" "Optional.None"
, AliasFromModule "Vector"
["single", "prepend", "map", "fold-left", "concatenate", "append"] ["empty"]
, AliasFromModule "Text"
["concatenate", "left", "right", "center", "justify"] []
, AliasFromModule "Remote"
["fork", "receive", "receiveAsync", "pure", "bind", "map", "channel", "send", "here", "at", "spawn"] []
, AliasFromModule "Color" ["rgba"] []
, AliasFromModule "Symbol" ["Symbol"] []
, AliasFromModule "Index" ["lookup", "unsafeLookup", "insert", "unsafeInsert", "empty", "unsafeEmpty"] []
, AliasFromModule "Html" ["getLinks", "getHref", "getDescription"] []
, AliasFromModule "Http" ["getURL", "unsafeGetURL"] []
, Alias "Unit" "()"
, Alias "Some" "Optional.Some"
, Alias "None" "Optional.None"
, Alias "+" "Number.+"
, Alias "-" "Number.-"
, Alias "*" "Number.*"
, Alias "/" "Number./"
, AliasFromModule "Vector" ["single"] []
, AliasFromModule "Remote" ["pure", "bind", "pure", "fork"] []
] >>= 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 "Symbol"
, builtin "Alignment"
, builtin "Color"
, builtin "Fixity"
, builtin "Pair"
, builtin "Order"
, builtin "Comparison"
, builtin "Order.Key"
-- 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)

22
shared/src/Unison/Remote.hs
View File

@ -100,8 +100,10 @@ data Local t
| CreateChannel
-- here : Local Node
| Here
-- receiveAsync : Channel a -> Local (Local a)
| ReceiveAsync Channel Timeout
-- sleep : Duration -> Local ()
| 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)
instance ToJSON Timeout
instance FromJSON Timeout
instance Hashable Timeout where
newtype Duration = Seconds { seconds :: Double } deriving (Eq,Ord,Show,Generic)
instance ToJSON Duration
instance FromJSON Duration
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

21
shared/src/Unison/Term.hs
View File

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

250
shared/src/Unison/TermParser.hs
View File

@ -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 = infixApp term4 <|> term4
term3 :: Var v => Parser (S v) (Term v)
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 = asum [hashLit, prefixTerm, lit, parenthesized term, blank, vector term]
termLeaf :: Var v => Parser (S v) (Term v)
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 }
-- Remote { action1; action2; }
-- Remote { action1; x = 1 + 1; action2; }
effectBlock :: (Var v, Show v) => Parser (Term v)
effectBlock = do
name <- wordyId <* token (string "{")
let qualifiedPure = ABT.var' (Text.pack name `mappend` Text.pack ".pure")
qualifiedBind = ABT.var' (Text.pack name `mappend` Text.pack ".bind")
bindings <- some $ asum [Right <$> binding qualifiedPure, Left <$> action qualifiedPure]
Just result <- pure $ foldr (bind qualifiedBind) Nothing bindings
result <$ lineErrorUnless "missing }" (token (string "}"))
where
bind qb = go where
go (Right (lhs,rhs)) (Just acc) = Just $ qb `Term.apps` [Term.lam lhs acc, rhs]
go (Right (_,_)) Nothing = Nothing
go (Left action) (Just acc) = Just $ qb `Term.apps` [Term.lam (ABT.v' "_") acc, action]
go (Left action) _ = Just action
interpretPure qp = ABT.subst (ABT.v' "pure") qp
binding qp = scope "binding" $ do
lhs <- ABT.v' . Text.pack <$> token wordyId
eff <- token $ (True <$ string ":=") <|> (False <$ string "=")
rhs <- term <* token (string ";")
let rhs' = if eff then interpretPure qp rhs
else qp `Term.app` rhs
pure (lhs, rhs')
action qp = attempt . scope "action" $ (interpretPure qp <$> term) <* token (string ";")
-- do Remote x := pure 23; y := at node2 23; pure 19;;
-- do Remote action1; action2;;
-- do Remote action1; x = 1 + 1; action2;;
-- do Remote
-- x := pure 23;
-- y = 11;
-- pure (f x);;
effectBlock :: forall v . Var v => Parser (S v) (Term v)
effectBlock = (token (string "do") *> wordyId keywords) >>= go where
go name = do
bindings <- some $ asum [Right <$> binding, Left <$> action] <* semicolon
semicolon
Just result <- pure $ foldr bind Nothing bindings
pure result
where
qualifiedPure, qualifiedBind :: Term v
qualifiedPure = ABT.var' (Text.pack name `mappend` Text.pack ".pure")
qualifiedBind = ABT.var' (Text.pack name `mappend` Text.pack ".bind")
bind :: (Either (Term v) (v, Term v)) -> Maybe (Term v) -> Maybe (Term v)
bind = go where
go (Right (lhs,rhs)) (Just acc) = Just $ qualifiedBind `Term.apps` [Term.lam lhs acc, rhs]
go (Right (_,_)) Nothing = Nothing
go (Left action) (Just acc) = Just $ qualifiedBind `Term.apps` [Term.lam (ABT.v' "_") acc, action]
go (Left action) _ = Just action
interpretPure :: Term v -> Term v
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_ p = f <$> (let_ *> optional rec_) <*> bindings' <* in_ <*> body
let_ :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
let_ p = f <$> (let_ *> optional rec_) <*> bindings'
where
let_ = token (string "let")
rec_ = token (string "rec") $> ()
bindings' = lineErrorUnless "error parsing let bindings" (bindings p)
in_ = lineErrorUnless "missing 'in' after bindings in let-expression'" $ token (string "in")
body = lineErrorUnless "parse error in body of let-expression" p
-- f = maybe Term.let1'
f :: Ord v => Maybe () -> [(v, Term v)] -> Term v -> Term v
f Nothing bindings body = Term.let1 bindings body
f (Just _) bindings body = Term.letRec bindings body
bindings' = do
bs <- lineErrorUnless "error parsing let bindings" (bindings p)
body <- lineErrorUnless "parse error in body of let-expression" term
semicolon2
pure (bs, body)
f :: Ord v => Maybe () -> ([(v, Term v)], Term v) -> Term v
f Nothing (bindings, body) = Term.let1 bindings body
f (Just _) (bindings, body) = Term.letRec bindings body
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 :: Var v => Parser (S v) (v, Type v)
typedecl = (,) <$> prefixVar <*> ann''
prefixBinding :: (Var v, Show v) => Parser (Term v) -> Parser (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 :: Parser (S v) (Term v) -> Parser (S v) (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
wordyId :: Parser String
wordyId = token $ f <$> id <*> optional ((:) <$> dot <*> wordyId)
infixVar :: Var v => Parser s v
infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId keywords)
where
dot = char '.'
id = identifier [any (not.isDigit), any isAlphaNum, (`notElem` keywords)]
f id rest = maybe id (id++) rest
backticked = char '`' *> wordyId keywords <* token (char '`')
-- a symbolyId is all symbols
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 v => Parser s v
prefixVar = (Var.named . Text.pack) <$> prefixOp
where
prefixOp :: Parser String
prefixOp = wordyId <|> (char '(' *> symbolyId <* token (char ')')) -- no whitespace w/in parens
prefixOp = wordyId keywords <|> (char '(' *> symbolyId keywords <* 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 = Set.fromList ["let", "rec", "in", "->", ":", "=", "where"]
keywords :: [String]
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)]
bindings p = --many (binding term)
sepBy1 (token (char ';' <|> char '\n')) (prefixBinding p <|> infixBinding p)
alias :: Var v => Parser (S v) ()
alias = do
_ <- 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)

4
shared/src/Unison/Type.hs
View File

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

80
shared/src/Unison/TypeParser.hs
View File

@ -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 rec = fmap (foldl1' Type.app) (some rec)
app :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
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 = identifier [isLower.head, all isAlpha]
varName :: Parser s String
varName = do
name <- wordyId keywords
guard (isLower . head $ name)
pure name
typeName :: Parser String
typeName = identifier [isUpper.head]
typeName :: Parser s String
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 =
token $ asum [ Type.lit Type.Number <$ string "Number"
, Type.lit Type.Text <$ string "Text"
, Type.lit Type.Vector <$ string "Vector"
, (Type.v' . Text.pack) <$> typeName
]
literal :: Var v => Parser (S v) (Type v)
literal = scope "literal" . token $
asum [ Type.lit Type.Number <$ string "Number"
, Type.lit Type.Text <$ string "Text"
, Type.lit Type.Vector <$ string "Vector"
, (Type.v' . Text.pack) <$> typeName
]

58
shared/src/Unison/Typechecker/Context.hs
View File

@ -477,10 +477,11 @@ annotateLetRecBindings letrec = do
pure $ (marker, body)
-- | Infer the type of a literal
synthLit :: Ord v => Term.Literal -> Type v
synthLit lit = Type.lit $ case lit of
Term.Number _ -> Type.Number
Term.Text _ -> Type.Text
synthLit :: Var v => Term.Literal -> Type v
synthLit lit = case lit of
Term.Number _ -> Type.lit Type.Number
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) =
-- innermost Ref annotation assumed to be correctly provided by `synthesizeClosed`
pure (ABT.vmap TypeVar.Universal t)
go (Term.Ann' (Term.Ref' _) t) = case ABT.freeVars t of
s | Set.null s ->
-- 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.fork", Type.forall' ["a"] (remote' (v' "a") --> remote' unitT))
, ("Remote.here", remote' (Type.builtin "Node"))
, ("Remote.spawn", remote' (Type.builtin "Node"))
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote' unitT))
, ("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.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.receiveAsync", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote' (remote' (v' "a"))))
, ("Remote.receive", Type.forall' ["a"] (channel (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.here", remote (Type.builtin "Node"))
, ("Remote.spawn", remote (Type.builtin "Node"))
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote unitT))
, ("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.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.receive-async", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote (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

12
shared/src/Unison/Util/Logger.hs
View File

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

5
shared/tests/Suite.hs
View File

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

27
shared/tests/Unison/Test/Common.hs
View File

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

99
shared/tests/Unison/Test/Interpreter.hs
View File

@ -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 "if False 0 1" "1"
, t "if True 12 13" "12"
, t "1 > 0" "True"
, t "1 == 1" "True"
, t "2 == 0" "False"
, t "1 < 2" "True"
, t "1 <= 1" "True"
, t "1 >= 1" "True"
, t "let rec fac n = if (n == 0) 1 (n * fac (n - 1)) in fac 5" "120"
, t "let rec ping n = if (n >= 10) n (pong (n + 1)); pong n = ping (n + 1) in ping 0"
, t "let x = 2; y = 3 ; x + y;;" "5"
, t "if False then 0 else 1" "1"
, t "if True then 12 else 13" "12"
, t "1 >_Number 0" "True"
, t "1 ==_Number 1" "True"
, t "2 ==_Number 0" "False"
, t "1 <_Number 2" "True"
, t "1 <=_Number 1" "True"
, t "1 >=_Number 1" "True"
, t "Comparison.fold 1 0 0 Less" "1"
, 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 : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" in g" "42"
, t "((let id x = x in id) : forall a . a -> a) 42" "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\" ; g;;" "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
let term = unsafeParseTerm uneval
(node, _, builtins) <- node
-- 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)]
assertEqual "comparing results" (unsafeParseTerm eval) result
[(_,_,result)] <- Note.run $ Node.evaluateTerms node [([], term)]
assertEqual "comparing results" (P.unsafeParseTerm eval) result
in testGroup "Interpreter" tests
main = defaultMain tests

118
shared/tests/Unison/Test/Term.hs
View File

@ -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) ->
let t = unsafeParseTerm "Number.plus 1 1"
in assertEqual "+"
"1 + 1"
(Doc.formatText (Width 80) (Views.term symbol t))
, testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol) ->
let t = unsafeParseTerm "Number.plus _"
in assertEqual "+"
"(+) _"
(Doc.formatText (Width 80) (Views.term symbol t))
, testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol) ->
let t = unsafeParseTerm "Number.plus"
in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
, testCase "infix-rendering (2)" $ node >>= \(_,symbol) ->
do
t <- pure $ unsafeParseTerm "Number.plus 1 1"
let d = Views.term symbol t
assertEqual "path sanity check"
[Paths.Fn,Paths.Arg]
(head $ Doc.leafPaths d)
, testCase "let-rendering (1)" $ node >>= \node ->
do
-- let xy = 4223 in 42
t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
[(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
assertEqual "p1" [] p1
assertEqual "p2" [] p2
assertEqual "r1" (rect 0 0 19 1) r1
assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
assertEqual "r3" (rect 9 0 4 1) r3
assertEqual "p3 == p4" p3 p4
assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
assertEqual "r5" (rect 4 0 2 1) r5
assertEqual "p6" [Paths.Binding 0] p6
assertEqual "r6" (rect 4 0 9 1) r6
, testCase "map lambda rendering" $ node >>= \node ->
do
-- map (x -> _) [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
assertEqual "p1" [Paths.Fn, Paths.Arg] p1
assertEqual "r1" (rect 4 0 8 1) r1
, testCase "operator chain rendering" $ node >>= \node ->
do
t <- pure $ unsafeParseTerm "1 + 2 + 3"
[(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
assertEqual "r1" (rect 0 0 1 1) r1
assertEqual "p2" [] p2
-- , testCase "infix-rendering (1)" $ node >>= \(_,symbol,_) ->
-- let t = unsafeParseTerm "Number.plus 1 1"
-- in assertEqual "+"
-- "1 + 1"
-- (Doc.formatText (Width 80) (Views.term symbol t))
-- , testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol,_) ->
-- let t = unsafeParseTerm "Number.plus _"
-- in assertEqual "+"
-- "(+) _"
-- (Doc.formatText (Width 80) (Views.term symbol t))
-- , testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol,_) ->
-- let t = unsafeParseTerm "Number.plus"
-- in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
-- , testCase "infix-rendering (2)" $ node >>= \(_,symbol,_) ->
-- do
-- t <- pure $ unsafeParseTerm "Number.plus 1 1"
-- let d = Views.term symbol t
-- assertEqual "path sanity check"
-- [Paths.Fn,Paths.Arg]
-- (head $ Doc.leafPaths d)
-- , testCase "let-rendering (1)" $ node >>= \node ->
-- do
-- -- let xy = 4223 in 42
-- t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
-- [(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
-- assertEqual "p1" [] p1
-- assertEqual "p2" [] p2
-- assertEqual "r1" (rect 0 0 19 1) r1
-- assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
-- assertEqual "r3" (rect 9 0 4 1) r3
-- assertEqual "p3 == p4" p3 p4
-- assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
-- assertEqual "r5" (rect 4 0 2 1) r5
-- assertEqual "p6" [Paths.Binding 0] p6
-- assertEqual "r6" (rect 4 0 9 1) r6
-- , testCase "map lambda rendering" $ node >>= \node ->
-- do
-- -- map (x -> _) [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
-- assertEqual "p1" [Paths.Fn, Paths.Arg] p1
-- assertEqual "r1" (rect 4 0 8 1) r1
-- , testCase "operator chain rendering" $ node >>= \node ->
-- do
-- t <- pure $ unsafeParseTerm "1 + 2 + 3"
-- [(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
-- assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
-- assertEqual "r1" (rect 0 0 1 1) r1
-- 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)"
, " ; pong = y -> ping (y - 1)"
, " in ping 1"
unlines [ "let rec "
, " ping x = pong (x + 1);"
, " pong y = ping (y - 1);"
, " ping 1;;"
]
pingpong2 :: TTerm
pingpong2 =
unsafeParseTerm $
unlines [ "let rec pong1 = p -> ping1 (p - 1)"
, " ; ping1 = q -> pong1 (q + 1)"
, " in ping1 1"
]
unsafeParseTerm $ "let rec pong1 p = ping1 (p - 1); ping1 q = pong1 (q + 1); ping1 1;;"

66
shared/tests/Unison/Test/TermParser.hs
View File

@ -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 : Int; a = 1 in 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 in a + 1", let_a_int1_in_aplus1)
, ("let a:Int; a = 1 in a + 1", let_a_int1_in_aplus1)
, ("let a = 1; a + 1;;", let1' [("a", one)] (apps numberplus [a, one]))
, ("let a : Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
, ("let a: Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
, ("let a :Int; a = 1; 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 in 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 a + b = f a b in 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 in 1 + 1", plusintintint_fab_in_1plus1)
, ("let (+) : Int -> Int -> Int; (+) a b = f a b in (+) 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 = a b -> a + b; 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; f g 1;;", let1' [("f", lam' ["+", "b"] (apps plus [one, b]))] (apps f [g,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; 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; (+) 1 1;;", plusintintint_fab_in_1plus1)
, ("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) in fix", fix) -- fix
, ("let rec fix = f -> f (fix f); 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)
, ("Remote { x = 42; pure (x + 1); }",
, ("(do Remote pure 42;;)", builtin "Remote.pure" `app` num 42)
, ("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
numberplus = builtin "Number.plus"
plus' x y = builtin "Number.+" `app` x `app` y
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"

2
shared/tests/Unison/Test/TypeParser.hs
View File

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

38
shared/tests/Unison/Test/Typechecker.hs
View File

@ -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
(unsafeParseTerm "let f = (+) in f 1")
, testCase "synthesize/check (let f = (+); f 1;;)" $ synthesizesAndChecks node
(unsafeParseTerm "let f = (+); f 1;;")
(T.lit T.Number --> T.lit T.Number)
, testCase "synthesize/check (let blank x = _ in blank 1)" $ synthesizesAndChecks node
(unsafeParseTerm "let blank x = _ in blank 1")
, testCase "synthesize/check (let blank x = _; blank 1;;)" $ synthesizesAndChecks node
(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 = 42; y = _ in _" $ \tms ->
-- testTerm "let x = 42; y = 43 in _" $ \tms ->
-- testTerm "let x = 42; y = 43 in 4224" $ \tms ->
, testTerm "let x = _; y = _; _;;" $ \tms ->
-- testTerm "let x = 42; y = _; _" $ \tms ->
-- testTerm "let x = 42; y = 43; _" $ \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

27
shared/tests/Unison/Test/Typechecker/Components.hs
View File

@ -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"
"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; y;;"
-- check that we get let generalization
, t "let rec id x = x; g = id 42; y = id id g in y"
"let 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; 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"
"let 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; id3;;"
-- check that we reorder according to dependencies
, t "let rec g = id 42; y = id id g; id x = x in y"
"let id x = x; g = id 42; y = id id g 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; 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"
"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)"
, 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 ; (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'

2
shared/unison-shared.cabal
View File

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

5
stack.yaml
View File

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

268
unison-src/base.u Normal file
View File

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

11
unison-src/dindex-main.u Normal file
View File

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

98
unison-src/dindex.u Normal file
View File

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

119
unison-src/extra.u Normal file
View File

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

5
unison-src/fork.u Normal file
View File

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

2
node/tests/html.u → unison-src/html.u
View File

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

14
node/tests/index.u → unison-src/index.u
View File

@ -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;
pure ind;
};
Index.insert "Alice" "Jones" ind;
Index.insert "Bob" "Smith" ind;
pure ind;;
;
Remote.transfer n2;
Index.lookup "Unison" ind;
}
Index.lookup "Alice" ind;;

13
unison-src/indexed-traversal.u Normal file
View File

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

17
unison-src/pingpong.u Normal file
View File

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

6
unison-src/race.u Normal file
View File

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

8
unison-src/receive-async.u Normal file
View File

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

94
unison-src/searchengine.u Normal file
View File

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