mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
examples working again, needed to resurrect Remote.map builtin
This commit is contained in:
parent
744ca6ccf0
commit
fdac639034
@ -1,5 +1,6 @@
|
||||
{-# Language BangPatterns #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language CPP #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -22,7 +23,11 @@ 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.Text as Text
|
||||
#ifdef leveldb
|
||||
import qualified Unison.BlockStore.LevelDbStore as LDBS
|
||||
#else
|
||||
import qualified Unison.BlockStore.FileBlockStore as FBS
|
||||
#endif
|
||||
import qualified Unison.NodeContainer as C
|
||||
import qualified Unison.NodeProtocol as NP
|
||||
import qualified Unison.Remote as R
|
||||
@ -32,8 +37,12 @@ import qualified Unison.Typechecker.Components as Components
|
||||
main :: IO ()
|
||||
main = Mux.uniqueChannel >>= \rand ->
|
||||
let
|
||||
fileBS = FBS.make' rand h "blockstore"
|
||||
h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
|
||||
#ifdef leveldb
|
||||
blockstore = LDBS.make rand h "blockstore.leveldb"
|
||||
#else
|
||||
blockstore = FBS.make' rand h "blockstore"
|
||||
#endif
|
||||
locker _ = pure held
|
||||
held = Lock (pure (Just (Lease (pure True) (pure ()))))
|
||||
mkNode _ = do -- todo: actually use node params
|
||||
@ -55,8 +64,13 @@ main = Mux.uniqueChannel >>= \rand ->
|
||||
P.std_in = P.CreatePipe,
|
||||
P.std_err = P.CreatePipe }
|
||||
in do
|
||||
fileBS <- fileBS
|
||||
send <- C.make fileBS locker protocol mkNode launchNode
|
||||
#ifdef leveldb
|
||||
putStrLn "using leveldb-based block store"
|
||||
#else
|
||||
putStrLn "using file-based block store"
|
||||
#endif
|
||||
blockstore <- blockstore
|
||||
send <- C.make blockstore locker protocol mkNode launchNode
|
||||
S.scotty 8081 $ do
|
||||
S.middleware logStdoutDev
|
||||
S.addroute OPTIONS (S.regex ".*") $ NS.originOptions
|
||||
|
@ -4,13 +4,11 @@ module Main where
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Monad
|
||||
import System.Directory (doesDirectoryExist)
|
||||
import System.IO (stderr)
|
||||
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 Control.Concurrent.STM as STM
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
@ -21,7 +19,7 @@ import qualified Unison.Eval.Interpreter as I
|
||||
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 Store
|
||||
import qualified Unison.Node.MemStore as Store
|
||||
import qualified Unison.Note as Note
|
||||
import qualified Unison.Parsers as Parsers
|
||||
import qualified Unison.Reference as Reference
|
||||
@ -40,12 +38,14 @@ main = do
|
||||
lang logger crypto blockstore = do
|
||||
let b0 = Builtin.makeBuiltins
|
||||
b1 <- ExtraBuiltins.makeAPI blockstore crypto
|
||||
store <- Store.make "codestore"
|
||||
store <- Store.make
|
||||
backend <- BasicNode.make SAH.hash store (\whnf -> b0 whnf ++ b1 whnf)
|
||||
loadDeclarations "unison-src/base.u" backend
|
||||
loadDeclarations "unison-src/extra.u" backend
|
||||
initialized <- STM.atomically $ newTVar False
|
||||
pure $ go backend initialized b0 b1
|
||||
pure $ go backend initialized
|
||||
where
|
||||
go backend initialized b0 b1 =
|
||||
go backend initialized =
|
||||
let
|
||||
lang :: R.Language TermV Hash
|
||||
lang = R.Language localDependencies eval apply node unit channel local unRemote remote
|
||||
@ -69,13 +69,15 @@ main = do
|
||||
Right _ -> pure (Right e')
|
||||
initialize = do
|
||||
L.info logger "checking if base libraries loaded"
|
||||
alreadyInitialized <- doesDirectoryExist "codestore"
|
||||
let idf = Term.lam' ["x"] (Term.var' "x") :: TermV
|
||||
let Reference.Derived hashIdf = SAH.hash idf
|
||||
alreadyInitialized <- pure False -- not . null <$> R.getHashes codestore (Set.fromList [hashIdf])
|
||||
when (not alreadyInitialized) $ do
|
||||
L.info logger "codestore/ directory not found, loading base libraries..."
|
||||
loadDeclarations "unison-src/base.u" backend
|
||||
loadDeclarations "unison-src/extra.u" backend
|
||||
L.info logger "codestore not loaded... inserting"
|
||||
hs <- Note.run (Node.allTerms backend)
|
||||
R.saveHashes codestore [ (h,v) | (Reference.Derived h, v) <- hs ]
|
||||
-- todo
|
||||
-- R.saveHashes codestore [ (h,v) | (Reference.Derived h, v) <- hs ]
|
||||
pure ()
|
||||
STM.atomically $ writeTVar initialized True
|
||||
in (lang, typecheck, initialize)
|
||||
apply = Term.app
|
||||
@ -89,7 +91,9 @@ main = do
|
||||
loadDeclarations path node = do
|
||||
txt <- Text.IO.readFile path
|
||||
let str = Text.unpack txt
|
||||
L.info logger $ "loading " ++ path
|
||||
r <- Note.run $ Node.declare' Term.ref str node
|
||||
L.info logger $ "done loading " ++ path
|
||||
L.info logger $ "loaded " ++ path
|
||||
L.debug' logger $ do
|
||||
ts <- Note.run $ Node.allTermsByVarName Term.ref node
|
||||
pure $ show ts
|
||||
pure r
|
||||
|
@ -149,6 +149,7 @@ library
|
||||
|
||||
if flag(leveldb)
|
||||
build-depends: exceptions, leveldb-haskell
|
||||
cpp-options: -Dleveldb
|
||||
exposed-modules:
|
||||
Unison.BlockStore.LevelDbStore
|
||||
|
||||
@ -190,9 +191,6 @@ executable worker
|
||||
unison-shared,
|
||||
vector
|
||||
|
||||
if flag(leveldb)
|
||||
build-depends: exceptions, leveldb-haskell
|
||||
|
||||
executable container
|
||||
main-is: Container.hs
|
||||
hs-source-dirs: src
|
||||
@ -242,6 +240,7 @@ executable container
|
||||
|
||||
if flag(leveldb)
|
||||
build-depends: exceptions, leveldb-haskell
|
||||
cpp-options: -Dleveldb
|
||||
|
||||
executable node
|
||||
main-is: Node.hs
|
||||
|
@ -153,13 +153,13 @@ makeBuiltins whnf =
|
||||
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")
|
||||
--, 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.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"
|
||||
op [chan, timeout] = do
|
||||
Term.Number' seconds <- whnf timeout
|
||||
|
@ -1,3 +1,6 @@
|
||||
identity : ∀ a . a -> a;
|
||||
identity a = a;
|
||||
|
||||
Remote.transfer : Node -> Remote Unit;
|
||||
Remote.transfer node = Remote.at node unit;
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user