mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge pull request #117 from unisonweb/topic/searchengine
"Working" search engine example
This commit is contained in:
commit
f3c701198d
2
.gitignore
vendored
2
.gitignore
vendored
@ -10,7 +10,9 @@ cabal-dev
|
|||||||
**/cache/**
|
**/cache/**
|
||||||
**/build/**
|
**/build/**
|
||||||
store
|
store
|
||||||
|
codestore
|
||||||
tags
|
tags
|
||||||
|
unison-src/.loaded
|
||||||
**cabal.sandbox.config
|
**cabal.sandbox.config
|
||||||
.cabal-sandbox/**
|
.cabal-sandbox/**
|
||||||
|
|
||||||
|
@ -16,7 +16,7 @@ import qualified Data.Text as Text
|
|||||||
import qualified Unison.Term as E
|
import qualified Unison.Term as E
|
||||||
import qualified Unison.Var as Var
|
import qualified Unison.Var as Var
|
||||||
|
|
||||||
term :: Parser [Term V]
|
term :: Parser () [Term V]
|
||||||
term =
|
term =
|
||||||
msum
|
msum
|
||||||
[ single . E.lit . E.Text . Text.pack <$> quotedString
|
[ single . E.lit . E.Text . Text.pack <$> quotedString
|
||||||
@ -30,22 +30,22 @@ term =
|
|||||||
where
|
where
|
||||||
single x = [x]
|
single x = [x]
|
||||||
|
|
||||||
digits :: Parser String
|
digits :: Parser () String
|
||||||
digits = takeWhile Char.isDigit
|
digits = takeWhile "digits" Char.isDigit
|
||||||
|
|
||||||
digits1 :: Parser String
|
digits1 :: Parser () String
|
||||||
digits1 = (:) <$> one Char.isDigit <*> digits
|
digits1 = (:) <$> one Char.isDigit <*> digits
|
||||||
|
|
||||||
floatingPoint :: Parser Double
|
floatingPoint :: Parser () Double
|
||||||
floatingPoint = do
|
floatingPoint = do
|
||||||
d <- digits1
|
d <- digits1
|
||||||
rest <- optional (void (char '.') *> ((++) <$> pure "0." <*> (fromMaybe "0" <$> optional digits1)))
|
rest <- optional (void (char '.') *> ((++) <$> pure "0." <*> (fromMaybe "0" <$> optional digits1)))
|
||||||
pure $ read d + fromMaybe 0.0 (read <$> rest)
|
pure $ read d + fromMaybe 0.0 (read <$> rest)
|
||||||
|
|
||||||
quotedString :: Parser String
|
quotedString :: Parser () String
|
||||||
quotedString = char '\"' *> takeWhile (\c -> c /= '\"') <* optional (char '\"')
|
quotedString = char '\"' *> takeWhile "quoted string" (\c -> c /= '\"') <* optional (char '\"')
|
||||||
|
|
||||||
intro :: Parser [Term V]
|
intro :: Parser () [Term V]
|
||||||
intro = do
|
intro = do
|
||||||
let sym = (Var.named . Text.pack <$> token (identifier [])) <|> pure (Var.named "_")
|
let sym = (Var.named . Text.pack <$> token (identifier [])) <|> pure (Var.named "_")
|
||||||
let lam v = E.lam v E.blank
|
let lam v = E.lam v E.blank
|
||||||
|
@ -1,5 +1,7 @@
|
|||||||
{-# Language BangPatterns #-}
|
{-# Language BangPatterns #-}
|
||||||
{-# Language OverloadedStrings #-}
|
{-# Language OverloadedStrings #-}
|
||||||
|
{-# Language PartialTypeSignatures #-}
|
||||||
|
{-# Language CPP #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
@ -9,11 +11,11 @@ import Data.Bytes.Serial (serialize)
|
|||||||
import Data.Text.Encoding (decodeUtf8)
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
import Network.HTTP.Types.Method (StdMethod(OPTIONS))
|
import Network.HTTP.Types.Method (StdMethod(OPTIONS))
|
||||||
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
|
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
|
||||||
import System.IO (hSetBinaryMode, hFlush, stdin)
|
import System.IO (stdout)
|
||||||
import System.Process as P
|
import Unison.Hash (Hash)
|
||||||
import Unison.NodeProtocol.V0 (protocol)
|
import Unison.NodeProtocol.V0 (protocol)
|
||||||
import Unison.NodeServer as NS
|
import Unison.NodeServer as NS
|
||||||
import Unison.Parsers (unsafeParseTermWithPrelude)
|
import Unison.Parsers (unsafeParseTerm)
|
||||||
import Unison.Runtime.Lock (Lock(..),Lease(..))
|
import Unison.Runtime.Lock (Lock(..),Lease(..))
|
||||||
import Web.Scotty as S
|
import Web.Scotty as S
|
||||||
import qualified Data.ByteArray as BA
|
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.Base64.URL as Base64
|
||||||
import qualified Data.ByteString.Lazy as LB
|
import qualified Data.ByteString.Lazy as LB
|
||||||
import qualified Data.Bytes.Put as Put
|
import qualified Data.Bytes.Put as Put
|
||||||
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Text as Text
|
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.NodeContainer as C
|
||||||
import qualified Unison.NodeProtocol as NP
|
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.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.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 :: IO ()
|
||||||
main = Mux.uniqueChannel >>= \rand ->
|
main = do
|
||||||
let
|
logger <- Config.loggerTo stdout
|
||||||
fileBS = FBS.make' rand h "blockstore"
|
rand <- Mux.uniqueChannel
|
||||||
h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
|
let h bytes = BA.convert (hash bytes :: Digest Blake2b_512)
|
||||||
locker _ = pure held
|
#ifdef leveldb
|
||||||
|
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 ()))))
|
held = Lock (pure (Just (Lease (pure True) (pure ()))))
|
||||||
mkNode _ = do -- todo: actually use node params
|
mkNode _ = do -- todo: actually use node params
|
||||||
publicKey <- Put.runPutS . serialize <$> rand
|
publicKey <- Put.runPutS . serialize <$> rand
|
||||||
pure $ R.Node "localhost" publicKey
|
pure $ Remote.Node "localhost" publicKey
|
||||||
launchNode node = do
|
lang :: Remote.Language SAH.TermV Hash
|
||||||
(Just stdin, Just stdout, Just stderr, handle) <- P.createProcess_ "node-worker" cmd
|
lang = Remote.Language localDependencies eval Term.app Term.node
|
||||||
hSetBinaryMode stdin True
|
(Term.builtin "()") Term.channel local unRemote Term.remote
|
||||||
B.hPut stdin . Put.runPutS $ do
|
local l = Term.remote (Remote.Step (Remote.Local l))
|
||||||
serialize ("ignored-private-key" :: B.ByteString)
|
unRemote (Term.Distributed' (Term.Remote r)) = Just r
|
||||||
serialize node
|
unRemote _ = Nothing
|
||||||
serialize (R.Universe "local-universe")
|
codestore = Remote.makeCodestore blockstore :: Remote.Codestore SAH.TermV Hash
|
||||||
serialize B.empty -- no sandbox specification
|
localDependencies _ = Set.empty -- todo, compute this for real
|
||||||
hFlush stdin
|
whnf e = do -- todo: may want to have this use evaluator + codestore directly
|
||||||
let proof = "not-real-delete-proof"
|
[(_,_,e)] <- Node.evaluateTerms backend [([], e)]
|
||||||
pure (stdin, stdout, stderr, handle, proof)
|
pure e
|
||||||
cmd = (P.shell "stack exec worker") {
|
eval t = Note.run (whnf t)
|
||||||
P.std_out = P.CreatePipe,
|
-- evaluator = I.eval allprimops
|
||||||
P.std_in = P.CreatePipe,
|
-- allbuiltins = b0 whnf ++ b1 whnf
|
||||||
P.std_err = P.CreatePipe }
|
-- allprimops = Map.fromList [ (r, op) | Builtin.Builtin r (Just op) _ _ <- allbuiltins ]
|
||||||
in do
|
typecheck e = do
|
||||||
fileBS <- fileBS
|
bindings <- Note.run $ Node.allTermsByVarName Term.ref backend
|
||||||
send <- C.make fileBS locker protocol mkNode launchNode
|
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.scotty 8081 $ do
|
||||||
S.middleware logStdoutDev
|
S.middleware logStdoutDev
|
||||||
S.addroute OPTIONS (S.regex ".*") $ NS.originOptions
|
S.addroute OPTIONS (S.regex ".*") $ NS.originOptions
|
||||||
NS.postRoute "/compute/:nodepk" $ do
|
NS.postRoute "/compute/:nodepk" $ do
|
||||||
nodepk <- S.param "nodepk"
|
nodepk <- S.param "nodepk"
|
||||||
let node = R.Node "localhost" (Put.runPutS . serialize . Base64.decodeLenient $ nodepk)
|
let node = Remote.Node "localhost" (Put.runPutS . serialize . Base64.decodeLenient $ nodepk)
|
||||||
programtxt <- S.body
|
programtxt <- S.body
|
||||||
let programstr = Text.unpack (decodeUtf8 (LB.toStrict programtxt))
|
let programstr = Text.unpack (decodeUtf8 (LB.toStrict programtxt))
|
||||||
let !prog = unsafeParseTermWithPrelude programstr
|
let !prog = unsafeParseTerm programstr
|
||||||
let !prog' = Components.minimize' prog
|
let !prog' = Components.minimize' prog
|
||||||
liftIO . putStrLn $ "parsed " ++ show prog
|
liftIO $ L.info logger "parsed"
|
||||||
liftIO . putStrLn $ "parsed' " ++ show prog'
|
|
||||||
let destination = Put.runPutS (serialize node)
|
let destination = Put.runPutS (serialize node)
|
||||||
let pk = Mux.Packet (Mux.channelId $ NP._localEval protocol) (Put.runPutS (serialize prog'))
|
let pk = Mux.Packet (Mux.channelId $ NP._localEval protocol) (Put.runPutS (serialize prog'))
|
||||||
liftIO $ send (Mux.Packet destination (Put.runPutS (serialize pk)))
|
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
|
||||||
|
@ -3,6 +3,7 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import System.IO
|
||||||
import Unison.Hash.Extra ()
|
import Unison.Hash.Extra ()
|
||||||
import Unison.Node.Store (Store)
|
import Unison.Node.Store (Store)
|
||||||
import Unison.Reference (Reference)
|
import Unison.Reference (Reference)
|
||||||
@ -26,6 +27,7 @@ import qualified Unison.Runtime.ExtraBuiltins as EB
|
|||||||
import qualified Unison.Symbol as Symbol
|
import qualified Unison.Symbol as Symbol
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
import qualified Unison.View as View
|
import qualified Unison.View as View
|
||||||
|
import qualified Unison.Util.Logger as L
|
||||||
|
|
||||||
hash :: Var v => Term.Term v -> Reference
|
hash :: Var v => Term.Term v -> Reference
|
||||||
hash (Term.Ref' r) = r
|
hash (Term.Ref' r) = r
|
||||||
@ -43,10 +45,12 @@ makeRandomAddress crypt = Address <$> C.randomBytes crypt 64
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr]
|
||||||
store' <- store
|
store' <- store
|
||||||
|
logger <- L.atomic (L.atInfo L.toStandardError)
|
||||||
let crypto = C.noop "dummypublickey"
|
let crypto = C.noop "dummypublickey"
|
||||||
blockStore <- FBS.make' (makeRandomAddress crypto) makeAddress "Index"
|
blockStore <- FBS.make' (makeRandomAddress crypto) makeAddress "Index"
|
||||||
keyValueOps <- EB.makeAPI blockStore crypto
|
keyValueOps <- EB.make logger blockStore crypto
|
||||||
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
|
let makeBuiltins whnf = concat [Builtin.makeBuiltins logger whnf, keyValueOps whnf]
|
||||||
node <- BasicNode.make hash store' makeBuiltins
|
node <- BasicNode.make hash store' makeBuiltins
|
||||||
NodeServer.server 8080 node
|
NodeServer.server 8080 node
|
||||||
|
@ -57,11 +57,11 @@ make bs = let
|
|||||||
StoreData trm tym (Map.insert ref met mm)
|
StoreData trm tym (Map.insert ref met mm)
|
||||||
in do
|
in do
|
||||||
journaledStore <- J.fromBlocks bs apply keyframeBlock updateBlock
|
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
|
<$> 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
|
<$> 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
|
<$> J.get journaledStore
|
||||||
writeTerm h t = Note.lift $ J.update (WriteTerm h t) journaledStore
|
writeTerm h t = Note.lift $ J.update (WriteTerm h t) journaledStore
|
||||||
annotateTerm r t = Note.lift $ J.update (AnnotateTerm r t) journaledStore
|
annotateTerm r t = Note.lift $ J.update (AnnotateTerm r t) journaledStore
|
||||||
|
@ -1,24 +1,27 @@
|
|||||||
|
{-# Language DeriveGeneric #-}
|
||||||
{-# Language OverloadedStrings #-}
|
{-# Language OverloadedStrings #-}
|
||||||
|
|
||||||
module Unison.NodeContainer where
|
module Unison.NodeContainer where
|
||||||
|
|
||||||
import Control.Concurrent (forkIO)
|
import Control.Concurrent (forkIO)
|
||||||
import Control.Concurrent.Chan.Unagi
|
import Control.Concurrent.Chan.Unagi
|
||||||
|
import Control.Concurrent.STM (STM)
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Bytes.Serial (Serial)
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import System.IO (hClose, hFlush, Handle)
|
import GHC.Generics
|
||||||
import Unison.Runtime.Remote ()
|
import Unison.Runtime.Remote ()
|
||||||
import qualified Control.Concurrent.Async as Async
|
import qualified Control.Concurrent.Async as Async
|
||||||
|
import qualified Control.Concurrent.STM as STM
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
|
import qualified Data.ByteArray as BA
|
||||||
import qualified Data.ByteString.Base64.URL as Base64
|
import qualified Data.ByteString.Base64.URL as Base64
|
||||||
import qualified Data.Bytes.Get as Get
|
import qualified Data.Bytes.Get as Get
|
||||||
import qualified Data.Bytes.Put as Put
|
import qualified Data.Bytes.Put as Put
|
||||||
import qualified Data.Bytes.Serial as S
|
import qualified Data.Bytes.Serial as S
|
||||||
import qualified Data.Trie as Trie
|
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.BlockStore as BS
|
||||||
import qualified Unison.Config as Config
|
import qualified Unison.Config as Config
|
||||||
import qualified Unison.NodeProtocol as P
|
import qualified Unison.NodeProtocol as P
|
||||||
@ -30,19 +33,22 @@ import qualified Unison.Util.Logger as L
|
|||||||
type Trie = Trie.Trie
|
type Trie = Trie.Trie
|
||||||
type DeleteProof = ByteString
|
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)
|
make :: (Ord h, S.Serial h, S.Serial hash)
|
||||||
=> BS.BlockStore h
|
=> BS.BlockStore h
|
||||||
-> (Remote.Node -> IO L.Lock)
|
-> (Remote.Node -> IO L.Lock)
|
||||||
-> P.Protocol term hash h thash
|
-> P.Protocol term hash h thash
|
||||||
-> (ByteString -> IO Remote.Node)
|
-> (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 ())
|
-> IO (Mux.Packet -> IO ())
|
||||||
make bs nodeLock p genNode launchNodeCmd = do
|
make bs nodeLock p genNode launchNode = do
|
||||||
logger <- L.scope "container" <$> Config.loggerStandardOut
|
logger <- L.scope "container" <$> Config.loggerStandardOut
|
||||||
-- packet queue, processed by main `go` loop below
|
-- packet queue, processed by main `go` loop below
|
||||||
(packetWrite, packetRead) <- newChan :: IO (InChan Mux.Packet, OutChan Mux.Packet)
|
(packetWrite, packetRead) <- newChan :: IO (InChan Mux.Packet, OutChan Mux.Packet)
|
||||||
-- routing trie for packets; initially empty
|
-- routing trie for packets; initially empty
|
||||||
routing <- newIORef (Trie.empty :: Trie (ByteString -> IO ()))
|
routing <- newIORef (Trie.empty :: Trie (Mux.Packet -> IO ()))
|
||||||
(writeChan packetWrite <$) . forkIO $
|
(writeChan packetWrite <$) . forkIO $
|
||||||
let
|
let
|
||||||
go = forever $ do
|
go = forever $ do
|
||||||
@ -67,45 +73,44 @@ make bs nodeLock p genNode launchNodeCmd = do
|
|||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
Just lease -> do
|
Just lease -> do
|
||||||
L.info logger $ "waking up node " ++ show node
|
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
|
Just dest -> do
|
||||||
L.debug logger "destination exists; routing"
|
L.debug logger "destination exists; routing"
|
||||||
safely (dest (Mux.content packet))
|
safely (dest packet)
|
||||||
|
|
||||||
nodeSeries node = BS.Series $ "node-" `mappend` Remote.publicKey node
|
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
|
-- 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
|
-- 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
|
logger <- pure $ L.scope (show . Base64.encode . Remote.publicKey $ node) logger
|
||||||
let send bytes = writeChan toNodeWrite bytes
|
let send pk = case Get.runGetS S.deserialize (Mux.content pk) of
|
||||||
let nodebytes = Put.runPutS $ S.serialize node
|
Left err -> L.warn logger $ "packet decoding error: " ++ err
|
||||||
|
Right pk -> writeChan toNodeWrite (Just pk)
|
||||||
|
nodebytes = Put.runPutS $ S.serialize node
|
||||||
atomicModifyIORef routing $ \t -> (Trie.insert nodebytes send t, ())
|
atomicModifyIORef routing $ \t -> (Trie.insert nodebytes send t, ())
|
||||||
forM_ packets send
|
send packet
|
||||||
let removeRoute = atomicModifyIORef' routing $ \t -> (Trie.delete nodebytes t, ())
|
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
|
void . forkIO . handle (\e -> L.warn logger (show (e :: SomeException)) >> removeRoute) $ do
|
||||||
(stdin, stdout, stderr, process, deleteProof) <- launchNodeCmd node
|
L.debug logger "waking.."
|
||||||
L.logHandleAt logger L.errorLevel stderr
|
(write, read, isActive, deleteProof) <- launchNode logger node
|
||||||
-- read from the process as quickly as possible, buffering input in a queue
|
L.debug logger "awakened"
|
||||||
(fromNodeWrite, fromNodeRead) <- newChan
|
|
||||||
:: IO (InChan (Maybe Mux.Packet), OutChan (Maybe Mux.Packet))
|
-- deregister the node when idle
|
||||||
let write a _ = writeChan fromNodeWrite a
|
_ <- Async.async $ do
|
||||||
reader <- Async.async $ Mux.deserializeHandle stdout B.empty write
|
STM.atomically $ do a <- isActive; when a STM.retry
|
||||||
-- now that we have a handle to the process, we write to it from the `toNodeRead` queue
|
L.info logger "node idle, removing route"
|
||||||
|
removeRoute
|
||||||
|
|
||||||
|
-- thread for writing to the node, just processes the `toNodeRead` queue
|
||||||
writer <- Async.async . forever $ do
|
writer <- Async.async . forever $ do
|
||||||
(bytes, force) <- tryReadChan toNodeRead
|
pk <- readChan toNodeRead
|
||||||
bytes <- tryRead bytes >>= \bytes -> case bytes of
|
L.debug logger $ "writing packet: " ++ show pk
|
||||||
Nothing -> hFlush stdin >> force -- flush buffer whenever there's a pause
|
write pk
|
||||||
Just bytes -> pure bytes -- we're saturating the channel, no need to flush manually
|
|
||||||
let nodeBytes = Put.runPutS (S.serialize node)
|
|
||||||
L.trace logger $ "writing bytes " ++ show (B.length bytes)
|
|
||||||
safely $
|
|
||||||
B.hPut stdin bytes `onException`
|
|
||||||
writeChan packetWrite (Mux.Packet nodeBytes bytes)
|
|
||||||
|
|
||||||
-- establish routes for processing packets coming from the node
|
-- establish routes for processing packets coming from the node
|
||||||
routes <- id $
|
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 :: (S.Serial a, S.Serial b) => (a -> IO b) -> ByteString -> IO ()
|
||||||
handleRequest h bytes = safely $ do
|
handleRequest h bytes = safely $ do
|
||||||
(a, replyTo) <- either fail pure (Get.runGetS S.deserialize bytes)
|
(a, replyTo) <- either fail pure (Get.runGetS S.deserialize bytes)
|
||||||
|
L.debug logger $ "got request " ++ show (Base64.encode replyTo)
|
||||||
b <- h a
|
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)
|
insert = handleRequest (BS.insert bs)
|
||||||
lookup = handleRequest (BS.lookup bs)
|
lookup = handleRequest (BS.lookup bs)
|
||||||
declare = handleRequest (BS.declareSeries bs)
|
declare = handleRequest (BS.declareSeries bs)
|
||||||
@ -141,15 +148,16 @@ make bs nodeLock p genNode launchNodeCmd = do
|
|||||||
h0 <- BS.declareSeries bs series
|
h0 <- BS.declareSeries bs series
|
||||||
Just _ <- BS.update bs series h0 nodeParams
|
Just _ <- BS.update bs series h0 nodeParams
|
||||||
pure node
|
pure node
|
||||||
delete proof | proof /= deleteProof = pure ()
|
delete proof | BA.constEq proof deleteProof = pure ()
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
send (Put.runPutS $ S.serialize (Nothing :: Maybe Mux.Packet))
|
writeChan toNodeWrite Nothing
|
||||||
BS.deleteSeries bs (BS.Series $ Remote.publicKey node)
|
BS.deleteSeries bs (BS.Series $ Remote.publicKey node)
|
||||||
removeRoute
|
removeRoute
|
||||||
in pure routes
|
in pure routes
|
||||||
|
|
||||||
processor <- Async.async . Mux.repeatWhile $ do
|
processor <- Async.async . Mux.repeatWhile $ do
|
||||||
nodePacket <- readChan fromNodeRead
|
L.debug logger $ "processor about to read"
|
||||||
|
nodePacket <- read
|
||||||
case nodePacket of
|
case nodePacket of
|
||||||
Nothing -> False <$ L.info logger "processor completed"
|
Nothing -> False <$ L.info logger "processor completed"
|
||||||
Just packet -> True <$ do
|
Just packet -> True <$ do
|
||||||
@ -163,17 +171,11 @@ make bs nodeLock p genNode launchNodeCmd = do
|
|||||||
writeChan packetWrite packet -- forwarded to main loop
|
writeChan packetWrite packet -- forwarded to main loop
|
||||||
|
|
||||||
_ <- forkIO $ do
|
_ <- forkIO $ do
|
||||||
exitCode <- Process.waitForProcess process
|
r <- Async.waitCatch processor
|
||||||
L.debug logger "worker process terminated"
|
L.debug logger $ "worker process terminated with: " ++ show r
|
||||||
removeRoute
|
_ <- Async.waitCatch writer
|
||||||
_ <- Async.waitCatch reader
|
L.debug logger "worker writer thread terminated"
|
||||||
L.debug logger "worker reader thread terminated"
|
|
||||||
Async.cancel writer
|
|
||||||
_ <- Async.waitCatch processor
|
|
||||||
mapM_ (safely . hClose) [stdin, stdout]
|
|
||||||
case exitCode of
|
|
||||||
Exit.ExitSuccess -> L.info logger $ "node process terminated"
|
|
||||||
Exit.ExitFailure n -> L.warn logger $ "node process exited with: " ++ show n
|
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
safely :: IO () -> IO ()
|
safely :: IO () -> IO ()
|
||||||
|
@ -53,17 +53,17 @@ data Protocol term signature hash thash =
|
|||||||
blockStoreProxy :: (Serial hash) => Protocol term signature hash thash -> Mux.Multiplex (BlockStore hash)
|
blockStoreProxy :: (Serial hash) => Protocol term signature hash thash -> Mux.Multiplex (BlockStore hash)
|
||||||
blockStoreProxy p = go <$> Mux.ask
|
blockStoreProxy p = go <$> Mux.ask
|
||||||
where
|
where
|
||||||
timeout = 5000000 :: Mux.Microseconds
|
timeout = Mux.seconds 25
|
||||||
go env =
|
go env =
|
||||||
let
|
let
|
||||||
mt :: (Serial a, Serial b) => Request a b -> a -> IO b
|
mt :: (Serial a, Serial b) => String -> Request a b -> a -> IO b
|
||||||
mt chan a = Mux.run env . join $ Mux.requestTimed timeout chan a
|
mt msg chan a = Mux.run env . join $ Mux.requestTimed msg timeout chan a
|
||||||
insert bytes = mt (_insert p) bytes
|
insert bytes = mt "BlockStore.insert" (_insert p) bytes
|
||||||
lookup h = mt (_lookup p) h
|
lookup h = mt "BlockStore.lookup" (_lookup p) h
|
||||||
declare series = mt (_declare p) series
|
declare series = mt "BlockStore.declare" (_declare p) series
|
||||||
delete series = mt (_delete p) series
|
delete series = mt "BlockStore.delete" (_delete p) series
|
||||||
update series h bytes = mt (_update p) (series,h,bytes)
|
update series h bytes = mt "BlockStore.update" (_update p) (series,h,bytes)
|
||||||
append series h bytes = mt (_append p) (series,h,bytes)
|
append series h bytes = mt "BlockStore.append" (_append p) (series,h,bytes)
|
||||||
resolve series = mt (_resolve p) series
|
resolve series = mt "BlockStore.resolve" (_resolve p) series
|
||||||
resolves series = mt (_resolves p) series
|
resolves series = mt "BlockStore.resolves" (_resolves p) series
|
||||||
in BlockStore insert lookup declare delete update append resolve resolves
|
in BlockStore insert lookup declare delete update append resolve resolves
|
||||||
|
@ -4,32 +4,23 @@
|
|||||||
|
|
||||||
module Unison.NodeWorker where
|
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.Concurrent.STM.TSem
|
||||||
|
import Control.Exception.Base as Ex
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Data.Bytes.Serial (Serial, serialize, deserialize)
|
import Data.Bytes.Serial (Serial, serialize)
|
||||||
import Data.Serialize.Get (Get)
|
|
||||||
import GHC.Generics
|
|
||||||
import System.IO (stdin, hSetBinaryMode)
|
|
||||||
import Unison.BlockStore (BlockStore(..))
|
|
||||||
import Unison.Cryptography (Cryptography)
|
import Unison.Cryptography (Cryptography)
|
||||||
import Unison.Hash.Extra ()
|
import Unison.Hash.Extra ()
|
||||||
|
import qualified Control.Concurrent.Async as Async
|
||||||
import qualified Data.ByteArray as BA
|
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.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.NodeProtocol as P
|
||||||
import qualified Unison.Remote as Remote
|
import qualified Unison.Remote as Remote
|
||||||
import qualified Unison.Runtime.Multiplex as Mux
|
import qualified Unison.Runtime.Multiplex as Mux
|
||||||
import qualified Unison.Runtime.Remote as Remote
|
import qualified Unison.Runtime.Remote as Remote
|
||||||
import qualified Unison.Util.Logger as L
|
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
|
make :: ( BA.ByteArrayAccess key
|
||||||
, Serial signature
|
, Serial signature
|
||||||
, Serial term, Show term
|
, Serial term, Show term
|
||||||
@ -39,37 +30,55 @@ make :: ( BA.ByteArrayAccess key
|
|||||||
, Eq h
|
, Eq h
|
||||||
, Serial key
|
, Serial key
|
||||||
, Ord thash)
|
, Ord thash)
|
||||||
=> P.Protocol term hash h thash
|
=> L.Logger
|
||||||
-> (Keypair key -> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext)
|
-> P.Protocol term hash h thash
|
||||||
-> Get (Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
|
-> Cryptography key symmetricKey signKey skp signature hash Remote.Cleartext
|
||||||
-> BlockStore h
|
-> Remote.Language term thash
|
||||||
-> IO (Remote.Language term thash, term -> IO (Either String ())))
|
-> Remote.Node
|
||||||
-> IO ()
|
-> Remote.Universe
|
||||||
make protocol mkCrypto makeSandbox = do
|
-> (term -> IO (Either String term))
|
||||||
logger <- L.scope "worker" <$> Config.loggerStandardError
|
-> IO (Maybe Mux.Packet -> IO (), IO (Maybe Mux.Packet), STM Bool)
|
||||||
let die msg = liftIO $ L.error logger msg >> error ""
|
make logger protocol crypto sandbox node universe typecheck = do
|
||||||
L.info logger $ "initializing... "
|
logger <- pure $ L.scope "worker" logger
|
||||||
hSetBinaryMode stdin True
|
(env, toNode, fromNode, isActive) <- Mux.env0 logger
|
||||||
(privateKey, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize B.empty)
|
L.debug' logger $ do
|
||||||
(node, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
|
active <- atomically isActive
|
||||||
(universe, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
|
pure $ "active0: " ++ show active
|
||||||
(sandbox, _, rem) <- Mux.deserializeHandle1 stdin (Get.runGetPartial deserialize rem)
|
-- used to make sure we are listening on all channels before returning,
|
||||||
publicKey <- either die pure $ Get.runGetS deserialize (Remote.publicKey node)
|
-- otherwise the caller could experience packet drops when sending
|
||||||
let keypair = Keypair publicKey privateKey
|
ok <- atomically $ newTSem 0 -- incremented once initialization done
|
||||||
L.debug logger $ "remaining bytes: " ++ show (B.length rem)
|
L.debug logger "kicking off processor"
|
||||||
interrupt <- atomically $ newTSem 0
|
node <- processor ok env
|
||||||
Mux.runStandardIO logger (Mux.seconds 5) rem (atomically $ waitTSem interrupt) $ do
|
_ <- Async.async $ supervise ok env node
|
||||||
|
L.debug logger "about to wait on semaphore"
|
||||||
|
atomically $ waitTSem ok
|
||||||
|
L.debug logger "done waiting on semaphore"
|
||||||
|
threadDelay (1000 * 500)
|
||||||
|
L.debug' logger $ do
|
||||||
|
active <- atomically isActive
|
||||||
|
pure $ "active: " ++ show active
|
||||||
|
let toNode' pk = check >> toNode pk
|
||||||
|
fromNode' = check >> fromNode
|
||||||
|
check = atomically isActive >>= \a ->
|
||||||
|
if a then pure () else fail "inactive node"
|
||||||
|
pure (toNode', fromNode', isActive)
|
||||||
|
where
|
||||||
|
supervise ok env node = Async.waitCatch node >>= \e -> case e of
|
||||||
|
Left err | isCatchable err -> do
|
||||||
|
L.warn logger $ "error during node processing, restarting "
|
||||||
|
node <- processor ok env
|
||||||
|
supervise ok env node
|
||||||
|
Left err ->
|
||||||
|
L.info logger $ "shutting down node due to uncatchable error: " ++ show err
|
||||||
|
Right _ ->
|
||||||
|
L.info logger "shutting down node due to graceful termination"
|
||||||
|
processor ok env = Async.async . Mux.run env $ do
|
||||||
blockStore <- P.blockStoreProxy protocol
|
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
|
-- todo: load this from persistent store also
|
||||||
connectionSandbox <- pure $ Remote.ConnectionSandbox (\_ -> pure True) (\_ -> pure True)
|
connectionSandbox <- pure $ Remote.ConnectionSandbox (\_ -> pure True) (\_ -> pure True)
|
||||||
env <- liftIO $ Remote.makeEnv universe node blockStore
|
env <- liftIO $ Remote.makeEnv universe node blockStore
|
||||||
Mux.info $ "... done initializing"
|
server <- Remote.server crypto connectionSandbox env sandbox protocol
|
||||||
_ <- Remote.server crypto connectionSandbox env sandbox protocol
|
localEval <- do
|
||||||
_ <- do
|
|
||||||
(prog, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._localEval protocol)
|
(prog, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._localEval protocol)
|
||||||
Mux.fork . Mux.scope "_localEval" . Mux.repeatWhile $ do
|
Mux.fork . Mux.scope "_localEval" . Mux.repeatWhile $ do
|
||||||
e <- prog
|
e <- prog
|
||||||
@ -83,24 +92,34 @@ make protocol mkCrypto makeSandbox = do
|
|||||||
Mux.warn $ "typechecking failed on: " ++ show r
|
Mux.warn $ "typechecking failed on: " ++ show r
|
||||||
Mux.warn $ "typechecking error:\n" ++ err
|
Mux.warn $ "typechecking error:\n" ++ err
|
||||||
pure True
|
pure True
|
||||||
Right _ -> do
|
Right r -> do
|
||||||
Mux.debug "typechecked"
|
Mux.debug "typechecked"
|
||||||
r <- liftIO $ Remote.eval sandbox r
|
r <- liftIO $ Remote.eval sandbox r
|
||||||
Mux.debug $ "evaluated to " ++ show r
|
Mux.debug $ "evaluated to " ++ show r
|
||||||
case Remote.unRemote sandbox r of
|
case Remote.unRemote sandbox r of
|
||||||
Nothing -> True <$ (Mux.warn $ "received a non-Remote: " ++ show r)
|
Nothing -> True <$ (Mux.warn $ "received a non-Remote: " ++ show r)
|
||||||
Just r -> True <$ Mux.fork (Remote.handle crypto connectionSandbox env sandbox protocol r)
|
Just r -> True <$ Mux.fork (Remote.handle crypto connectionSandbox env sandbox protocol r)
|
||||||
_ <- do
|
destroyIn <- do
|
||||||
(destroy, cancel) <- Mux.subscribeTimed (Mux.seconds 60) (P._destroyIn protocol)
|
(destroy, _) <- Mux.subscribeTimed (Mux.seconds 60) (P._destroyIn protocol)
|
||||||
Mux.fork . Mux.repeatWhile $ do
|
Mux.fork . Mux.repeatWhile $ do
|
||||||
sig <- destroy
|
sig <- destroy
|
||||||
case sig of
|
case sig of
|
||||||
Just sig | BA.constEq skHash (Put.runPutS (serialize sig)) -> do
|
Just sig -> do
|
||||||
cancel
|
-- cancel
|
||||||
Mux.send (Mux.Channel Mux.Type skHash) ()
|
Mux.send (Mux.Channel Mux.Type (Put.runPutS (serialize sig))) ()
|
||||||
-- no other cleanup needed; container will reclaim resources and eventually
|
-- no other cleanup needed; container will reclaim resources and eventually
|
||||||
-- kill off linked child nodes
|
-- kill off linked child nodes
|
||||||
liftIO $ atomically (signalTSem interrupt)
|
|
||||||
pure False
|
pure False
|
||||||
_ -> pure True
|
_ -> 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)
|
||||||
|
|
||||||
|
@ -11,6 +11,6 @@ instance Serial1 Step
|
|||||||
instance Serial1 Local
|
instance Serial1 Local
|
||||||
instance Serial t => Serial (Step t)
|
instance Serial t => Serial (Step t)
|
||||||
instance Serial t => Serial (Local t)
|
instance Serial t => Serial (Local t)
|
||||||
instance Serial Timeout
|
instance Serial Duration
|
||||||
instance Serial Node
|
instance Serial Node
|
||||||
instance Serial Channel
|
instance Serial Channel
|
||||||
|
@ -10,10 +10,13 @@ import Unison.BlockStore (Series(..), BlockStore)
|
|||||||
import Unison.Node.Builtin
|
import Unison.Node.Builtin
|
||||||
import Unison.Parsers (unsafeParseType)
|
import Unison.Parsers (unsafeParseType)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
|
import Unison.Util.Logger (Logger)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Vector as Vector
|
import qualified Data.Vector as Vector
|
||||||
|
import qualified Network.URI as URI
|
||||||
import qualified Unison.Cryptography as C
|
import qualified Unison.Cryptography as C
|
||||||
import qualified Unison.Eval.Interpreter as I
|
import qualified Unison.Eval.Interpreter as I
|
||||||
|
import qualified Unison.Hash as Hash
|
||||||
import qualified Unison.Note as Note
|
import qualified Unison.Note as Note
|
||||||
import qualified Unison.Reference as R
|
import qualified Unison.Reference as R
|
||||||
import qualified Unison.Remote as Remote
|
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.SerializationAndHashing as SAH
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
import qualified Unison.Type as Type
|
import qualified Unison.Type as Type
|
||||||
|
-- import qualified Unison.Util.Logger as L
|
||||||
|
|
||||||
indexT :: Ord v => Type v -> Type v -> Type v
|
indexT :: Ord v => Type v -> Type v -> Type v
|
||||||
indexT k v = Type.ref (R.Builtin "Index") `Type.app` k `Type.app` 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]
|
index node h = Term.ref (R.Builtin "Index") `Term.apps` [Term.node node, h]
|
||||||
|
|
||||||
linkT :: Ord v => Type v
|
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 :: 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 -> Term.Term V
|
||||||
linkToTerm (Html.Link href description) = link (Term.lit $ Term.Text href)
|
linkToTerm (Html.Link href description) = link (Term.lit $ Term.Text href)
|
||||||
@ -46,29 +50,82 @@ pattern Index' node s <-
|
|||||||
(Term.Text' s)
|
(Term.Text' s)
|
||||||
|
|
||||||
pattern Link' href description <-
|
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' href))
|
||||||
(Term.Text' description)
|
(Term.Text' description)
|
||||||
|
|
||||||
-- TODO rewrite builtins not to use unsafe code
|
-- TODO rewrite builtins not to use unsafe code
|
||||||
makeAPI :: Eq a => BlockStore a -> C.Cryptography k syk sk skp s h ByteString
|
make :: Eq a
|
||||||
|
=> Logger -> BlockStore a -> C.Cryptography k syk sk skp s h ByteString
|
||||||
-> IO (WHNFEval -> [Builtin])
|
-> IO (WHNFEval -> [Builtin])
|
||||||
makeAPI blockStore crypto = do
|
make _ blockStore crypto = do
|
||||||
let nextID = do
|
let nextID = do
|
||||||
cp <- C.randomBytes crypto 64
|
cp <- C.randomBytes crypto 64
|
||||||
ud <- C.randomBytes crypto 64
|
ud <- C.randomBytes crypto 64
|
||||||
pure (Series cp, Series ud)
|
pure (Series cp, Series ud)
|
||||||
resourcePool <- RP.make 3 10 (Index.loadEncrypted blockStore crypto) Index.flush
|
resourcePool <- RP.make 3 10 (Index.loadEncrypted blockStore crypto) Index.flush
|
||||||
pure (\whnf -> map (\(r, o, t, m) -> Builtin r o t m)
|
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
|
op [self] = do
|
||||||
ident <- Note.lift nextID
|
ident <- Note.lift nextID
|
||||||
Term.Distributed' (Term.Node self) <- whnf self
|
Term.Distributed' (Term.Node self) <- whnf self
|
||||||
pure . index self . Term.lit . Term.Text . Index.idToText $ ident
|
pure . index self . Term.lit . Term.Text . Index.idToText $ ident
|
||||||
op _ = fail "Index.unsafeEmpty unpossible"
|
op _ = fail "Index.empty# unpossible"
|
||||||
type' = unsafeParseType "forall k v . Node -> Index k v"
|
type' = unsafeParseType "forall k v . Node -> Index k v"
|
||||||
in (r, Just (I.Primop 1 op), type', prefix "unsafeEmpty")
|
in (r, Just (I.Primop 1 op), type', prefix "Index.empty#")
|
||||||
, let r = R.Builtin "Index.unsafeLookup"
|
, let r = R.Builtin "Index.keys#"
|
||||||
|
op [indexToken] = do
|
||||||
|
Term.Text' h <- whnf indexToken
|
||||||
|
Note.lift $ do
|
||||||
|
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
|
||||||
|
flip finally cleanup $ do
|
||||||
|
keyBytes <- atomically $ Index.keys db
|
||||||
|
case traverse SAH.deserializeTermFromBytes keyBytes of
|
||||||
|
Left err -> fail ("Index.keys# could not deserialize: " ++ err)
|
||||||
|
Right terms -> pure $ Term.vector terms
|
||||||
|
op _ = fail "Index.keys# unpossible"
|
||||||
|
type' = unsafeParseType "forall k . Text -> Vector k"
|
||||||
|
in (r, Just (I.Primop 1 op), type', prefix "Index.keys#")
|
||||||
|
, let r = R.Builtin "Index.1st-key#"
|
||||||
|
op [indexToken] = do
|
||||||
|
Term.Text' h <- whnf indexToken
|
||||||
|
Note.lift $ do
|
||||||
|
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
|
||||||
|
flip finally cleanup $ do
|
||||||
|
keyBytes <- atomically $ Index.keys db
|
||||||
|
case keyBytes of
|
||||||
|
[] -> pure none
|
||||||
|
(keyBytes:_) -> case SAH.deserializeTermFromBytes keyBytes of
|
||||||
|
Left err -> fail ("Index.1st-key# could not deserialize: " ++ err)
|
||||||
|
Right terms -> pure $ some terms
|
||||||
|
op _ = fail "Index.1st-key# unpossible"
|
||||||
|
type' = unsafeParseType "forall k . Text -> Optional k"
|
||||||
|
in (r, Just (I.Primop 1 op), type', prefix "Index.1st-key#")
|
||||||
|
, let r = R.Builtin "Index.increment#"
|
||||||
|
op [key, indexToken] = do
|
||||||
|
key <- whnf key
|
||||||
|
Term.Text' h <- whnf indexToken
|
||||||
|
Note.lift $ do
|
||||||
|
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
|
||||||
|
flip finally cleanup $ do
|
||||||
|
entry <- atomically $ Index.lookupGT (SAH.hash' key) db
|
||||||
|
case entry of
|
||||||
|
Nothing -> pure none
|
||||||
|
Just (_, (keyBytes, _)) -> case SAH.deserializeTermFromBytes keyBytes of
|
||||||
|
Left err -> fail ("Index.increment# could not deserialize: " ++ err)
|
||||||
|
Right term -> pure $ some term
|
||||||
|
op _ = fail "Index.increment# unpossible"
|
||||||
|
type' = unsafeParseType "forall k . k -> Text -> Optional k"
|
||||||
|
in (r, Just (I.Primop 2 op), type', prefix "Index.increment#")
|
||||||
|
, let r = R.Builtin "Index.representation#"
|
||||||
|
op [index] = do
|
||||||
|
Index' node tok <- whnf index
|
||||||
|
pure $ pair' (Term.node node) (Term.text tok)
|
||||||
|
op _ = fail "Index.representation# unpossible"
|
||||||
|
type' = unsafeParseType "forall k v . Index k v -> (Node, Text)"
|
||||||
|
in (r, Just (I.Primop 1 op), type', prefix "Index.representation#")
|
||||||
|
, let r = R.Builtin "Index.lookup#"
|
||||||
op [key, indexToken] = inject g indexToken key where
|
op [key, indexToken] = inject g indexToken key where
|
||||||
inject g indexToken key = do
|
inject g indexToken key = do
|
||||||
i <- whnf indexToken
|
i <- whnf indexToken
|
||||||
@ -80,80 +137,77 @@ makeAPI blockStore crypto = do
|
|||||||
flip finally cleanup $ do
|
flip finally cleanup $ do
|
||||||
result <- atomically $ Index.lookup (SAH.hash' k) db
|
result <- atomically $ Index.lookup (SAH.hash' k) db
|
||||||
case result >>= (pure . SAH.deserializeTermFromBytes . snd) of
|
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
|
Just (Right t) -> pure $ some t
|
||||||
Nothing -> pure none
|
Nothing -> pure none
|
||||||
pure val
|
pure val
|
||||||
g s k = pure $ Term.ref r `Term.app` s `Term.app` k
|
g s k = pure $ Term.ref r `Term.app` s `Term.app` k
|
||||||
op _ = fail "Index.unsafeLookup unpossible"
|
op _ = fail "Index.lookup# unpossible"
|
||||||
type' = unsafeParseType "forall k v. k -> Index k v -> Optional v"
|
type' = unsafeParseType "forall k v . k -> Text -> Optional v"
|
||||||
in (r, Just (I.Primop 2 op), type', prefix "unsafeLookup")
|
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup#")
|
||||||
, let r = R.Builtin "Index.lookup"
|
, let r = R.Builtin "Index.delete#"
|
||||||
op [key, index] = do
|
op [key, indexToken] = do
|
||||||
Index' node tok <- whnf index
|
Term.Text' indexToken <- whnf indexToken
|
||||||
pure $
|
key <- whnf key
|
||||||
Term.builtin "Remote.map" `Term.apps` [
|
(db, cleanup) <- Note.lift . RP.acquire resourcePool . Index.textToId $ indexToken
|
||||||
Term.builtin "Index.unsafeLookup" `Term.app` key,
|
Note.lift . flip finally cleanup $ do
|
||||||
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
|
_ <- atomically $ Index.delete (SAH.hash' key) db
|
||||||
]
|
pure unitRef
|
||||||
op _ = fail "Index.lookup unpossible"
|
op _ = fail "Index.delete# unpossible"
|
||||||
type' = unsafeParseType "forall k v. k -> Index k v -> Remote (Optional v)"
|
type' = unsafeParseType "forall k . k -> Text -> Unit"
|
||||||
in (r, Just (I.Primop 2 op), type', prefix "lookup")
|
in (r, Just (I.Primop 2 op), type', prefix "Index.delete#")
|
||||||
, let r = R.Builtin "Index.unsafeInsert"
|
, let r = R.Builtin "Index.insert#"
|
||||||
op [k, v, index] = inject g k v index where
|
op [k, v, index] = do
|
||||||
inject g k v index = do
|
k <- whnf k
|
||||||
k' <- whnf k
|
v <- whnf v
|
||||||
v' <- whnf v
|
Term.Text' indexToken <- whnf index
|
||||||
s <- whnf index
|
|
||||||
g k' v' s
|
|
||||||
g k v (Term.Text' h) = do
|
|
||||||
Note.lift $ do
|
Note.lift $ do
|
||||||
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ h
|
(db, cleanup) <- RP.acquire resourcePool . Index.textToId $ indexToken
|
||||||
flip finally cleanup $ atomically
|
flip finally cleanup $ atomically
|
||||||
(Index.insert (SAH.hash' k) (SAH.serializeTerm k, SAH.serializeTerm v) db)
|
(Index.insert (SAH.hash' k) (SAH.serializeTerm k, SAH.serializeTerm v) db)
|
||||||
>>= atomically
|
>>= atomically
|
||||||
pure unitRef
|
pure unitRef
|
||||||
g k v index = pure $ Term.ref r `Term.app` k `Term.app` v `Term.app` index
|
op _ = fail "Index.insert# unpossible"
|
||||||
op _ = fail "Index.unsafeInsert unpossible"
|
type' = unsafeParseType "forall k v . k -> v -> Text -> Unit"
|
||||||
type' = unsafeParseType "forall k v. k -> v -> Index k v -> Unit"
|
in (r, Just (I.Primop 3 op), type', prefix "Index.insert#")
|
||||||
in (r, Just (I.Primop 3 op), type', prefix "unsafeInsert")
|
|
||||||
, let r = R.Builtin "Index.insert"
|
-- Html
|
||||||
op [key, value, index] = do
|
, let r = R.Builtin "Html.get-links"
|
||||||
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 [html] = do
|
op [html] = do
|
||||||
html' <- whnf html
|
html' <- whnf html
|
||||||
pure $ case html' of
|
pure $ case html' of
|
||||||
Term.Text' h -> Term.vector' . Vector.fromList . map linkToTerm
|
Term.Text' h -> Term.vector' . Vector.fromList . map linkToTerm
|
||||||
$ Html.getLinks h
|
$ Html.getLinks h
|
||||||
x -> Term.ref r `Term.app` x
|
x -> Term.ref r `Term.app` x
|
||||||
op _ = fail "Html.getLinks unpossible"
|
op _ = fail "Html.get-links unpossible"
|
||||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Link", prefix "getLinks")
|
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Html.Link", prefix "Html.get-links")
|
||||||
, let r = R.Builtin "Html.getHref"
|
, let r = R.Builtin "Html.plain-text"
|
||||||
|
op [html] = do
|
||||||
|
html' <- whnf html
|
||||||
|
pure $ case html' of
|
||||||
|
Term.Text' h -> Term.text $ Html.toPlainText h
|
||||||
|
x -> Term.ref r `Term.app` x
|
||||||
|
op _ = fail "Html.plain-text unpossible"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Text", prefix "Html.plain-text")
|
||||||
|
, let r = R.Builtin "Html.get-href"
|
||||||
op [link] = do
|
op [link] = do
|
||||||
link' <- whnf link
|
link' <- whnf link
|
||||||
pure $ case link' of
|
pure $ case link' of
|
||||||
Link' href _ -> Term.lit (Term.Text href)
|
Link' href _ -> Term.lit (Term.Text href)
|
||||||
x -> Term.ref r `Term.app` x
|
x -> Term.ref r `Term.app` x
|
||||||
op _ = fail "Html.getHref unpossible"
|
op _ = fail "Html.get-href unpossible"
|
||||||
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getHref")
|
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-href")
|
||||||
, let r = R.Builtin "Html.getDescription"
|
, let r = R.Builtin "Html.get-description"
|
||||||
op [link] = do
|
op [link] = do
|
||||||
link' <- whnf link
|
link' <- whnf link
|
||||||
pure $ case link' of
|
pure $ case link' of
|
||||||
Link' _ d -> Term.lit (Term.Text d)
|
Link' _ d -> Term.lit (Term.Text d)
|
||||||
x -> Term.ref r `Term.app` x
|
x -> Term.ref r `Term.app` x
|
||||||
op _ = fail "Html.getDescription unpossible"
|
op _ = fail "Html.get-description unpossible"
|
||||||
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getDescription")
|
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.get-description")
|
||||||
, let r = R.Builtin "Http.unsafeGetURL"
|
|
||||||
|
-- Http
|
||||||
|
, let r = R.Builtin "Http.get-url#"
|
||||||
op [url] = do
|
op [url] = do
|
||||||
url <- whnf url
|
url <- whnf url
|
||||||
case url of
|
case url of
|
||||||
@ -163,11 +217,87 @@ makeAPI blockStore crypto = do
|
|||||||
Right x -> right $ Term.text x
|
Right x -> right $ Term.text x
|
||||||
Left x -> left . Term.text . Text.pack $ show x
|
Left x -> left . Term.text . Text.pack $ show x
|
||||||
x -> pure $ Term.ref r `Term.app` x
|
x -> pure $ Term.ref r `Term.app` x
|
||||||
op _ = fail "Http.unsafeGetURL unpossible"
|
op _ = fail "Http.get-url# unpossible"
|
||||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "unsafeGetURL")
|
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.get-url#")
|
||||||
, let r = R.Builtin "Http.getURL"
|
|
||||||
op [url] = pure $ Term.builtin "Remote.pure" `Term.app`
|
, let r = R.Builtin "Uri.parse-scheme"
|
||||||
(Term.builtin "Http.unsafeGetURL" `Term.app` url)
|
op [Term.Text' url] = pure $ case URI.parseURI (Text.unpack url) of
|
||||||
op _ = fail "Http.getURL unpossible"
|
Nothing -> none
|
||||||
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "getURL")
|
Just uri -> some . Term.text . Text.pack $ URI.uriScheme uri
|
||||||
|
op _ = error "Uri.parse-scheme unpossible"
|
||||||
|
typ = "Text -> Optional Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Uri.parse-scheme")
|
||||||
|
|
||||||
|
, let r = R.Builtin "Uri.parse-authority"
|
||||||
|
op [Term.Text' url] = pure $
|
||||||
|
case URI.parseURI (Text.unpack url) >>= URI.uriAuthority of
|
||||||
|
Nothing -> none
|
||||||
|
Just auth -> some . Term.text . Text.pack $
|
||||||
|
URI.uriUserInfo auth ++ URI.uriRegName auth ++ URI.uriPort auth
|
||||||
|
op _ = error "Uri.parse-authority unpossible"
|
||||||
|
typ = "Text -> Optional Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Uri.parse-authority")
|
||||||
|
|
||||||
|
-- Hashing
|
||||||
|
-- add erase, comparison functions
|
||||||
|
, let r = R.Builtin "hash#"
|
||||||
|
op [e] = do
|
||||||
|
e <- whnf e
|
||||||
|
let h = Hash.base64 . Hash.fromBytes . SAH.hash' $ e
|
||||||
|
pure $ Term.builtin "Hash" `Term.app` (Term.text h)
|
||||||
|
op _ = fail "hash"
|
||||||
|
t = "forall a . a -> Hash a"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "hash#")
|
||||||
|
, let r = R.Builtin "Hash.base64"
|
||||||
|
op [e] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf e
|
||||||
|
pure (Term.text r1)
|
||||||
|
op _ = fail "Hash.base64"
|
||||||
|
t = "forall a . Hash a -> Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.base64")
|
||||||
|
, let r = R.Builtin "Hash.erase"
|
||||||
|
op [e] = pure e
|
||||||
|
op _ = fail "Hash.erase"
|
||||||
|
t = "forall a . Hash a -> Hash Unit"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "Hash.erase")
|
||||||
|
, let r = R.Builtin "Hash.=="
|
||||||
|
op [h1,h2] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||||
|
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||||
|
pure $ if r1 == r2 then true else false
|
||||||
|
op _ = fail "Hash.=="
|
||||||
|
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.==")
|
||||||
|
, let r = R.Builtin "Hash.<"
|
||||||
|
op [h1,h2] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||||
|
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||||
|
pure $ if r1 < r2 then true else false
|
||||||
|
op _ = fail "Hash.<"
|
||||||
|
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.<")
|
||||||
|
, let r = R.Builtin "Hash.<="
|
||||||
|
op [h1,h2] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||||
|
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||||
|
pure $ if r1 <= r2 then true else false
|
||||||
|
op _ = fail "Hash.<="
|
||||||
|
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.<=")
|
||||||
|
, let r = R.Builtin "Hash.>"
|
||||||
|
op [h1,h2] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||||
|
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||||
|
pure $ if r1 > r2 then true else false
|
||||||
|
op _ = fail "Hash.>"
|
||||||
|
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.>")
|
||||||
|
, let r = R.Builtin "Hash.>="
|
||||||
|
op [h1,h2] = do
|
||||||
|
Term.App' _ (Term.Text' r1) <- whnf h1
|
||||||
|
Term.App' _ (Term.Text' r2) <- whnf h2
|
||||||
|
pure $ if r1 >= r2 then true else false
|
||||||
|
op _ = fail "Hash.>="
|
||||||
|
in (r, Just (I.Primop 2 op), hashCompareTyp, prefix "Hash.>=")
|
||||||
|
, let r = R.Builtin "Hash.Order"
|
||||||
|
in (r, Nothing, unsafeParseType "∀ a . Order (Hash a)", prefix "Hash.Order")
|
||||||
])
|
])
|
||||||
|
|
||||||
|
hashCompareTyp :: Type V
|
||||||
|
hashCompareTyp = unsafeParseType "∀ a . Hash a -> Hash a -> Boolean"
|
||||||
|
@ -2,7 +2,7 @@ module Unison.Runtime.Html where
|
|||||||
|
|
||||||
import Data.Maybe (listToMaybe, catMaybes, mapMaybe)
|
import Data.Maybe (listToMaybe, catMaybes, mapMaybe)
|
||||||
import Data.Text (Text, toLower, pack)
|
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
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
data Link = Link { ref :: Text, description :: Text } deriving (Show)
|
data Link = Link { ref :: Text, description :: Text } deriving (Show)
|
||||||
@ -24,3 +24,17 @@ sectionToLink _ = Nothing
|
|||||||
|
|
||||||
getLinks :: Text -> [Link]
|
getLinks :: Text -> [Link]
|
||||||
getLinks s = mapMaybe sectionToLink . justAnchorSections $ parseTags s
|
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
|
||||||
|
@ -5,7 +5,9 @@ module Unison.Runtime.Index
|
|||||||
,Unison.Runtime.Index.insert
|
,Unison.Runtime.Index.insert
|
||||||
,Unison.Runtime.Index.lookupGT
|
,Unison.Runtime.Index.lookupGT
|
||||||
,Unison.Runtime.Index.flush
|
,Unison.Runtime.Index.flush
|
||||||
|
,entries
|
||||||
,idToText
|
,idToText
|
||||||
|
,keys
|
||||||
,load
|
,load
|
||||||
,loadEncrypted
|
,loadEncrypted
|
||||||
,textToId
|
,textToId
|
||||||
@ -17,12 +19,12 @@ import Data.ByteString (ByteString)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
import Unison.Cryptography
|
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 as B
|
||||||
import qualified Data.ByteString.Base64.URL as Base64
|
import qualified Data.ByteString.Base64.URL as Base64
|
||||||
import qualified Data.Map as Map
|
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 KeyHash = ByteString
|
||||||
type Key = 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 :: KeyHash -> Db -> STM (Maybe (Key, Value))
|
||||||
lookup kh (Db journaledMap _) = Map.lookup kh <$> J.get journaledMap
|
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
|
-- | Find next key in the Db whose key is greater than the provided key
|
||||||
lookupGT :: KeyHash -> Db -> STM (Maybe (KeyHash, (Key, Value)))
|
lookupGT :: KeyHash -> Db -> STM (Maybe (KeyHash, (Key, Value)))
|
||||||
lookupGT kh (Db journaledMap _) = Map.lookupGT kh <$> J.get journaledMap
|
lookupGT kh (Db journaledMap _) = Map.lookupGT kh <$> J.get journaledMap
|
||||||
|
@ -5,7 +5,6 @@
|
|||||||
|
|
||||||
module Unison.Runtime.Multiplex where
|
module Unison.Runtime.Multiplex where
|
||||||
|
|
||||||
import System.IO (Handle, stdin, stdout, hFlush, hSetBinaryMode)
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Concurrent.Async (Async)
|
import Control.Concurrent.Async (Async)
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
@ -33,13 +32,10 @@ import qualified Data.ByteArray as BA
|
|||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.Bytes.Get as Get
|
import qualified Data.Bytes.Get as Get
|
||||||
import qualified Data.Bytes.Put as Put
|
import qualified Data.Bytes.Put as Put
|
||||||
import qualified Data.Serialize.Get as Get
|
|
||||||
import qualified STMContainers.Map as M
|
import qualified STMContainers.Map as M
|
||||||
import qualified Unison.Cryptography as C
|
import qualified Unison.Cryptography as C
|
||||||
import qualified Unison.Runtime.Queue as Q
|
import qualified Unison.Runtime.Queue as Q
|
||||||
import qualified Unison.Util.Logger as L
|
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)
|
data Packet = Packet { destination :: !B.ByteString, content :: !B.ByteString } deriving (Generic)
|
||||||
instance Serial Packet
|
instance Serial Packet
|
||||||
@ -53,11 +49,31 @@ type IsSubscription = Bool
|
|||||||
data Callbacks =
|
data Callbacks =
|
||||||
Callbacks (M.Map B.ByteString (B.ByteString -> IO ())) (TVar Word64)
|
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)
|
newtype Multiplex a = Multiplex (ReaderT Env IO a)
|
||||||
deriving (Applicative, Alternative, Functor, Monad, MonadIO, MonadPlus, MonadReader Env)
|
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 a -> IO a
|
||||||
run env (Multiplex go) = runReaderT go env
|
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 -> SomeException -> IO a
|
||||||
handle env ex = run env (warn $ msg ++ " " ++ show ex) >> throwIO ex
|
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 Env
|
||||||
ask = Multiplex Reader.ask
|
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 :: Multiplex L.Logger
|
||||||
logger = do
|
logger = do
|
||||||
~(_, _, _, logger) <- ask
|
~(_, _, _, _, logger) <- ask
|
||||||
pure logger
|
pure logger
|
||||||
|
|
||||||
scope :: String -> Multiplex a -> Multiplex a
|
scope :: String -> Multiplex a -> Multiplex a
|
||||||
scope msg = local tweak where
|
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, warn, debug :: String -> Multiplex ()
|
||||||
info msg = logger >>= \logger -> liftIO $ L.info logger msg
|
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 :: IO (Maybe Packet) -> Multiplex ()
|
||||||
process recv = scope "Mux.process" $ do
|
process recv = scope "Mux.process" $ do
|
||||||
(_, Callbacks cbs cba, _, logger) <- ask
|
(_, Callbacks cbs _, _, _, logger) <- ask
|
||||||
liftIO . repeatWhile $ do
|
liftIO . repeatWhile $ do
|
||||||
packet <- recv
|
packet <- recv
|
||||||
case packet of
|
case packet of
|
||||||
@ -190,11 +118,10 @@ process recv = scope "Mux.process" $ do
|
|||||||
callback <- atomically $ M.lookup destination cbs
|
callback <- atomically $ M.lookup destination cbs
|
||||||
case callback of
|
case callback of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
L.warn logger $ "dropped packet @ " ++ show (Base64.encode destination)
|
L.info logger $ "dropped packet @ " ++ show (Base64.encode destination)
|
||||||
pure True
|
pure True
|
||||||
Just callback -> do
|
Just callback -> do
|
||||||
L.debug logger $ "packet delivered @ " ++ show (Base64.encode destination)
|
L.debug logger $ "packet delivered @ " ++ show (Base64.encode destination)
|
||||||
bumpActivity' cba
|
|
||||||
callback content
|
callback content
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
@ -253,40 +180,41 @@ type Request a b = Channel (a, Channel b)
|
|||||||
type Microseconds = Int
|
type Microseconds = Int
|
||||||
|
|
||||||
requestTimedVia' :: (Serial a, Serial b)
|
requestTimedVia' :: (Serial a, Serial b)
|
||||||
=> Microseconds
|
=> String
|
||||||
|
-> Microseconds
|
||||||
-> (STM (a, Channel b) -> Multiplex ())
|
-> (STM (a, Channel b) -> Multiplex ())
|
||||||
-> Channel b
|
-> Channel b
|
||||||
-> STM a
|
-> STM a
|
||||||
-> Multiplex (Multiplex b)
|
-> Multiplex (Multiplex b)
|
||||||
requestTimedVia' micros send replyTo a = do
|
requestTimedVia' msg micros send replyTo a = do
|
||||||
env <- ask
|
env <- ask
|
||||||
(receive, cancel) <- receiveCancellable replyTo
|
(receive, cancel) <- receiveCancellable replyTo
|
||||||
send $ (,replyTo) <$> a
|
send $ (,replyTo) <$> a
|
||||||
watchdog <- liftIO . C.forkIO $ do
|
watchdog <- liftIO . C.forkIO $ do
|
||||||
liftIO $ C.threadDelay micros
|
liftIO $ C.threadDelay micros
|
||||||
run env cancel
|
run env (cancel $ "requestTimedVia timeout " ++ msg)
|
||||||
pure $ receive <* liftIO (C.killThread watchdog)
|
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)
|
-> Multiplex (Multiplex b)
|
||||||
requestTimedVia micros req replyTo a =
|
requestTimedVia msg micros req replyTo a =
|
||||||
requestTimedVia' micros (send' req) replyTo a
|
requestTimedVia' msg micros (send' req) replyTo a
|
||||||
|
|
||||||
requestTimed' :: (Serial a, Serial b) => Microseconds -> Request a b -> STM a -> Multiplex (Multiplex b)
|
requestTimed' :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> STM a -> Multiplex (Multiplex b)
|
||||||
requestTimed' micros req a = do
|
requestTimed' msg micros req a = do
|
||||||
replyTo <- channel
|
replyTo <- channel
|
||||||
requestTimedVia micros req replyTo a
|
requestTimedVia msg micros req replyTo a
|
||||||
|
|
||||||
requestTimed :: (Serial a, Serial b) => Microseconds -> Request a b -> a -> Multiplex (Multiplex b)
|
requestTimed :: (Serial a, Serial b) => String -> Microseconds -> Request a b -> a -> Multiplex (Multiplex b)
|
||||||
requestTimed micros req a = do
|
requestTimed msg micros req a = do
|
||||||
replyTo <- channel
|
replyTo <- channel
|
||||||
env <- ask
|
env <- ask
|
||||||
(receive, cancel) <- receiveCancellable replyTo
|
(receive, cancel) <- receiveCancellable replyTo
|
||||||
send req (a, replyTo)
|
send req (a, replyTo)
|
||||||
watchdog <- liftIO . C.forkIO $ do
|
watchdog <- liftIO . C.forkIO $ do
|
||||||
liftIO $ C.threadDelay micros
|
liftIO $ C.threadDelay micros
|
||||||
run env cancel
|
run env (cancel $ "requestTimed timeout " ++ msg)
|
||||||
pure $ receive <* liftIO (C.killThread watchdog) <* cancel
|
pure $ receive <* liftIO (C.killThread watchdog) <* cancel ("requestTimed completed")
|
||||||
|
|
||||||
type Cleartext = B.ByteString
|
type Cleartext = B.ByteString
|
||||||
type Ciphertext = B.ByteString
|
type Ciphertext = B.ByteString
|
||||||
@ -294,18 +222,19 @@ type CipherState = (Cleartext -> STM Ciphertext, Ciphertext -> STM Cleartext)
|
|||||||
|
|
||||||
encryptedRequestTimedVia
|
encryptedRequestTimedVia
|
||||||
:: (Serial a, Serial b)
|
:: (Serial a, Serial b)
|
||||||
=> CipherState
|
=> String
|
||||||
|
-> CipherState
|
||||||
-> Microseconds
|
-> Microseconds
|
||||||
-> ((a,Channel b) -> Multiplex ())
|
-> ((a,Channel b) -> Multiplex ())
|
||||||
-> Channel b
|
-> Channel b
|
||||||
-> a
|
-> a
|
||||||
-> Multiplex b
|
-> Multiplex b
|
||||||
encryptedRequestTimedVia (_,decrypt) micros send replyTo@(Channel _ bs) a = do
|
encryptedRequestTimedVia msg (_,decrypt) micros send replyTo@(Channel _ bs) a = do
|
||||||
responseCiphertext <- receiveTimed micros (Channel Type bs)
|
responseCiphertext <- receiveTimed msg micros (Channel Type bs)
|
||||||
send (a, replyTo)
|
send (a, replyTo)
|
||||||
responseCiphertext <- responseCiphertext -- force the receive
|
responseCiphertext <- responseCiphertext -- force the receive
|
||||||
responseCleartext <- liftIO . atomically . decrypt $ responseCiphertext
|
responseCleartext <- liftIO . atomically . decrypt $ responseCiphertext
|
||||||
either fail pure $ Get.runGetS deserialize responseCleartext
|
either crash pure $ Get.runGetS deserialize responseCleartext
|
||||||
|
|
||||||
encryptAndSendTo
|
encryptAndSendTo
|
||||||
:: (Serial a, Serial node)
|
:: (Serial a, Serial node)
|
||||||
@ -329,13 +258,13 @@ fork m = do
|
|||||||
|
|
||||||
nest :: Serial k => k -> Multiplex a -> Multiplex a
|
nest :: Serial k => k -> Multiplex a -> Multiplex a
|
||||||
nest outer m = Reader.local tweak m where
|
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)
|
kbytes = Put.runPutS (serialize outer)
|
||||||
send' send p = send $ (\p -> Packet kbytes (Put.runPutS (serialize p))) <$> p
|
send' send p = send $ (\p -> Packet kbytes (Put.runPutS (serialize p))) <$> p
|
||||||
|
|
||||||
channel :: Multiplex (Channel a)
|
channel :: Multiplex (Channel a)
|
||||||
channel = do
|
channel = do
|
||||||
~(_,_,fresh,_) <- ask
|
~(_,_,fresh,_,_) <- ask
|
||||||
Channel Type <$> liftIO fresh
|
Channel Type <$> liftIO fresh
|
||||||
|
|
||||||
send :: Serial a => Channel a -> a -> Multiplex ()
|
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' :: Serial a => Channel a -> STM a -> Multiplex ()
|
||||||
send' (Channel _ key) a = do
|
send' (Channel _ key) a = do
|
||||||
~(send,_,_,_) <- ask
|
~(send,_,_,_,_) <- ask
|
||||||
liftIO . atomically $ send (Packet key . Put.runPutS . serialize <$> a)
|
liftIO . atomically $ send (Packet key . Put.runPutS . serialize <$> a)
|
||||||
|
|
||||||
receiveCancellable :: Serial a => Channel a -> Multiplex (Multiplex a, Multiplex ())
|
receiveCancellable' :: Channel a
|
||||||
receiveCancellable (Channel _ key) = do
|
-> Multiplex (Multiplex B.ByteString, String -> Multiplex ())
|
||||||
(_,Callbacks cbs cba,_,_) <- ask
|
receiveCancellable' chan@(Channel _ key) = do
|
||||||
|
(_,Callbacks cbs _,_,_,_) <- ask
|
||||||
result <- liftIO newEmptyMVar
|
result <- liftIO newEmptyMVar
|
||||||
liftIO . atomically $ M.insert (putMVar result . Right) key cbs
|
liftIO . atomically $ M.insert (void . tryPutMVar result . Right) key cbs
|
||||||
liftIO $ bumpActivity' cba
|
cancel <- pure $ \reason -> do
|
||||||
cancel <- pure $ do
|
|
||||||
liftIO . atomically $ M.delete key cbs
|
liftIO . atomically $ M.delete key cbs
|
||||||
liftIO $ putMVar result (Left "cancelled")
|
liftIO . void $ tryPutMVar result (Left $ "Mux.cancelled: " ++ reason)
|
||||||
force <- pure . liftIO $ do
|
force <- pure . scope (show chan) . scope "receiveCancellable" $ do
|
||||||
bytes <- takeMVar result
|
info "awaiting result"
|
||||||
bytes <- either fail pure bytes
|
bytes <- liftIO $ takeMVar result
|
||||||
either fail pure $ Get.runGetS deserialize bytes
|
info "got result"
|
||||||
|
bytes <- either crash pure bytes
|
||||||
|
info "got result bytes"
|
||||||
|
pure bytes
|
||||||
pure (force, cancel)
|
pure (force, cancel)
|
||||||
|
|
||||||
receiveTimed :: Serial a => Microseconds -> Channel a -> Multiplex (Multiplex a)
|
receiveCancellable :: Serial a => Channel a -> Multiplex (Multiplex a, String -> Multiplex ())
|
||||||
receiveTimed micros chan = do
|
receiveCancellable chan@(Channel _ key) = f <$> receiveCancellable' chan where
|
||||||
(force, cancel) <- receiveCancellable chan
|
f (get, cancel) = (g =<< get, cancel)
|
||||||
|
g bytes = either crash pure $ Get.runGetS deserialize bytes
|
||||||
|
|
||||||
|
receiveTimed' :: String -> Microseconds -> Channel a -> Multiplex (Multiplex B.ByteString)
|
||||||
|
receiveTimed' msg micros chan = do
|
||||||
|
(force, cancel) <- receiveCancellable' chan
|
||||||
env <- ask
|
env <- ask
|
||||||
watchdog <- liftIO . C.forkIO $ do
|
watchdog <- liftIO . C.forkIO $ do
|
||||||
liftIO $ C.threadDelay micros
|
liftIO $ C.threadDelay micros
|
||||||
run env cancel
|
run env (cancel $ "receiveTimed timeout during " ++ msg)
|
||||||
pure $ force <* liftIO (C.killThread watchdog) <* cancel
|
pure $ scope "receiveTimed" (force <* liftIO (C.killThread watchdog) <* cancel ("receiveTimed completed" ++ msg))
|
||||||
|
|
||||||
|
receiveTimed :: Serial a => String -> Microseconds -> Channel a -> Multiplex (Multiplex a)
|
||||||
|
receiveTimed msg micros chan = tweak <$> receiveTimed' msg micros chan where
|
||||||
|
tweak bytes = tweak' =<< bytes
|
||||||
|
tweak' bytes = either crash pure $ Get.runGetS deserialize bytes
|
||||||
|
|
||||||
|
-- Save a receive future as part of
|
||||||
|
saveReceive :: Microseconds
|
||||||
|
-> B.ByteString -> Multiplex B.ByteString -> Multiplex ()
|
||||||
|
saveReceive micros chan force = do
|
||||||
|
(_,_,_,recvs,_) <- ask
|
||||||
|
tid <- liftIO . C.forkIO $ do
|
||||||
|
C.threadDelay micros
|
||||||
|
atomically $ M.delete chan recvs
|
||||||
|
let force' = do
|
||||||
|
liftIO $ C.killThread tid
|
||||||
|
liftIO $ atomically (M.delete chan recvs)
|
||||||
|
force
|
||||||
|
liftIO . atomically $ M.insert force' chan recvs
|
||||||
|
|
||||||
|
restoreReceive :: B.ByteString -> Multiplex B.ByteString
|
||||||
|
restoreReceive chan = do
|
||||||
|
(_,_,_,recvs,_) <- ask
|
||||||
|
o <- liftIO . atomically $ M.lookup chan recvs
|
||||||
|
fromMaybe (crash $ "chan could not be restored: " ++ show (Base64.encode chan))
|
||||||
|
o
|
||||||
|
|
||||||
timeout' :: Microseconds -> a -> Multiplex a -> Multiplex a
|
timeout' :: Microseconds -> a -> Multiplex a -> Multiplex a
|
||||||
timeout' micros onTimeout m = fromMaybe onTimeout <$> timeout micros m
|
timeout' micros onTimeout m = fromMaybe onTimeout <$> timeout micros m
|
||||||
@ -413,15 +376,14 @@ subscribeTimed micros chan = do
|
|||||||
loop logger activity result cancel
|
loop logger activity result cancel
|
||||||
|
|
||||||
subscribe :: Serial a => Channel a -> Multiplex (Multiplex a, Multiplex ())
|
subscribe :: Serial a => Channel a -> Multiplex (Multiplex a, Multiplex ())
|
||||||
subscribe (Channel _ key) = do
|
subscribe (Channel _ key) = scope "subscribe" $ do
|
||||||
(_, Callbacks cbs cba, _, _) <- ask
|
(_, Callbacks cbs _, _, _, _) <- ask
|
||||||
q <- liftIO . atomically $ newTQueue
|
q <- liftIO . atomically $ newTQueue
|
||||||
liftIO . atomically $ M.insert (atomically . writeTQueue q) key cbs
|
liftIO . atomically $ M.insert (atomically . writeTQueue q) key cbs
|
||||||
liftIO $ bumpActivity' cba
|
|
||||||
unsubscribe <- pure . liftIO . atomically . M.delete key $ cbs
|
unsubscribe <- pure . liftIO . atomically . M.delete key $ cbs
|
||||||
force <- pure . liftIO $ do
|
force <- pure $ do
|
||||||
bytes <- atomically $ readTQueue q
|
bytes <- liftIO . atomically $ readTQueue q
|
||||||
either fail pure $ Get.runGetS deserialize bytes
|
either crash pure $ Get.runGetS deserialize bytes
|
||||||
pure (force, unsubscribe)
|
pure (force, unsubscribe)
|
||||||
|
|
||||||
seconds :: Microseconds -> Int
|
seconds :: Microseconds -> Int
|
||||||
@ -487,7 +449,7 @@ pipeInitiate crypto rootChan (recipient,recipientKey) u = scope "pipeInitiate" $
|
|||||||
bytes <- fetchh
|
bytes <- fetchh
|
||||||
debug "... handshake round trip completed"
|
debug "... handshake round trip completed"
|
||||||
case bytes of
|
case bytes of
|
||||||
Nothing -> cancelh >> cancelc >> fail "cancelled handshake"
|
Nothing -> cancelh >> cancelc >> crash "cancelled handshake"
|
||||||
Just bytes -> liftIO (atomically $ decrypt bytes) >> go
|
Just bytes -> liftIO (atomically $ decrypt bytes) >> go
|
||||||
|
|
||||||
-- todo: add access control here, better to bail ASAP (or after 1s delay
|
-- 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
|
(doneHandshake, senderKey, encrypt, decrypt) <- liftIO $ C.pipeResponder crypto
|
||||||
debug $ "decrypting initial payload"
|
debug $ "decrypting initial payload"
|
||||||
bytes <- (liftLogged "[Mux.pipeRespond] decrypt" . atomically . decrypt) 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
|
debug $ "handshake channels: " ++ show chans
|
||||||
let sender = extractSender u
|
let sender = extractSender u
|
||||||
handshakeSub <- subscribeTimed handshakeTimeout handshakeChan
|
handshakeSub <- subscribeTimed handshakeTimeout handshakeChan
|
||||||
@ -531,7 +493,7 @@ pipeRespond crypto allow _ extractSender payload = do
|
|||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
Just senderKey -> allow senderKey >>= \ok ->
|
Just senderKey -> allow senderKey >>= \ok ->
|
||||||
if ok then pure ()
|
if ok then pure ()
|
||||||
else liftIO (C.threadDelay delayBeforeFailure) >> fail "disallowed key"
|
else liftIO (C.threadDelay delayBeforeFailure) >> crash "disallowed key"
|
||||||
go = do
|
go = do
|
||||||
ready <- liftIO $ atomically doneHandshake
|
ready <- liftIO $ atomically doneHandshake
|
||||||
checkSenderKey
|
checkSenderKey
|
||||||
@ -545,5 +507,5 @@ pipeRespond crypto allow _ extractSender payload = do
|
|||||||
nest sender $ send' chanh (encrypt B.empty)
|
nest sender $ send' chanh (encrypt B.empty)
|
||||||
bytes <- fetchh
|
bytes <- fetchh
|
||||||
case bytes of
|
case bytes of
|
||||||
Nothing -> cancelh >> cancelc >> fail "cancelled handshake"
|
Nothing -> cancelh >> cancelc >> crash "cancelled handshake"
|
||||||
Just bytes -> liftIO (atomically $ decrypt bytes) >> go
|
Just bytes -> liftIO (atomically $ decrypt bytes) >> go
|
||||||
|
@ -4,6 +4,7 @@
|
|||||||
|
|
||||||
module Unison.Runtime.Remote where
|
module Unison.Runtime.Remote where
|
||||||
|
|
||||||
|
import Control.Concurrent.Async (Async)
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
@ -107,10 +108,10 @@ server :: (Ord h, Serial key, Serial t, Show t, Serial h)
|
|||||||
-> Env t h
|
-> Env t h
|
||||||
-> Language t h
|
-> Language t h
|
||||||
-> P.Protocol t hash h' h
|
-> P.Protocol t hash h' h
|
||||||
-> Multiplex ()
|
-> Multiplex (Async ())
|
||||||
server crypto allow env lang p = do
|
server crypto allow env lang p = do
|
||||||
(accept,_) <- Mux.subscribeTimed (Mux.seconds 60) (Mux.erase (P._eval p))
|
(accept,_) <- Mux.subscribeTimed (Mux.seconds 60) (Mux.erase (P._eval p))
|
||||||
void . Mux.fork . Mux.repeatWhile $ do
|
Mux.fork . Mux.repeatWhile $ do
|
||||||
initialPayload <- accept
|
initialPayload <- accept
|
||||||
case initialPayload of
|
case initialPayload of
|
||||||
Nothing -> pure False
|
Nothing -> pure False
|
||||||
@ -120,7 +121,7 @@ server crypto allow env lang p = do
|
|||||||
-- guard $ Put.runPutS (serialize peerKey) == publicKey peer
|
-- guard $ Put.runPutS (serialize peerKey) == publicKey peer
|
||||||
Mux.scope "Remote.server" . Mux.repeatWhile $ do
|
Mux.scope "Remote.server" . Mux.repeatWhile $ do
|
||||||
r <- recv
|
r <- recv
|
||||||
Mux.info $ "eval " ++ show r
|
Mux.debug $ "eval " ++ show r
|
||||||
case r of
|
case r of
|
||||||
Nothing -> pure False
|
Nothing -> pure False
|
||||||
Just (r, ackChan) -> do
|
Just (r, ackChan) -> do
|
||||||
@ -132,7 +133,8 @@ server crypto allow env lang p = do
|
|||||||
where
|
where
|
||||||
fetch hs = do
|
fetch hs = do
|
||||||
syncChan <- Mux.channel
|
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 | Set.null needs = pure ()
|
||||||
loop needs = fetch needs >>= \hashes -> case hashes of
|
loop needs = fetch needs >>= \hashes -> case hashes of
|
||||||
Nothing -> fail "expected hashes, got timeout"
|
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
|
client crypto allow env p n r
|
||||||
Mux.debug $ "transferred to node: " ++ show n
|
Mux.debug $ "transferred to node: " ++ show n
|
||||||
runLocal (Fork r) = do
|
runLocal (Fork r) = do
|
||||||
Mux.debug $ "runLocal Fork"
|
Mux.info $ "runLocal Fork"
|
||||||
Mux.fork (handle crypto allow env lang p r) $> unit lang
|
unit lang <$ Mux.fork (handle crypto allow env lang p r)
|
||||||
runLocal CreateChannel = do
|
runLocal CreateChannel = do
|
||||||
Mux.debug $ "runLocal CreateChannel"
|
Mux.debug $ "runLocal CreateChannel"
|
||||||
channel lang . Channel . Mux.channelId <$> Mux.channel
|
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)
|
pure $ node lang (currentNode env)
|
||||||
runLocal Spawn = do
|
runLocal Spawn = do
|
||||||
Mux.debug $ "runLocal Spawn"
|
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
|
n <- n
|
||||||
Mux.debug $ "runLocal Spawn completed: " ++ show n
|
Mux.debug $ "runLocal Spawn completed: " ++ show n
|
||||||
pure (node lang n)
|
pure (node lang n)
|
||||||
runLocal (Pure t) = do
|
runLocal (Pure t) = do
|
||||||
Mux.debug $ "runLocal Pure"
|
Mux.debug $ "runLocal Pure"
|
||||||
liftIO $ eval lang t
|
liftIO $ eval lang t
|
||||||
runLocal (Send (Channel cid) a) = do
|
runLocal (Send c@(Channel cid) a) = do
|
||||||
Mux.debug $ "runLocal Send " ++ show cid
|
Mux.debug $ "runLocal Send " ++ show c ++ " " ++ show a
|
||||||
|
a <- liftIO $ eval lang a
|
||||||
|
Mux.debug $ "runLocal Send[2] " ++ show c ++ " " ++ show a
|
||||||
Mux.process1 (Mux.Packet cid (Put.runPutS (serialize a)))
|
Mux.process1 (Mux.Packet cid (Put.runPutS (serialize a)))
|
||||||
pure (unit lang)
|
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
|
runLocal (ReceiveAsync chan@(Channel cid) (Seconds seconds)) = do
|
||||||
Mux.debug $ "runLocal ReceiveAsync " ++ show (seconds, cid)
|
Mux.debug $ "runLocal ReceiveAsync " ++ show (seconds, chan)
|
||||||
_ <- Mux.receiveTimed (floor $ seconds * 1000 * 1000) ((Mux.Channel Mux.Type cid) :: Mux.Channel (Maybe B.ByteString))
|
forceChan <- Mux.channel
|
||||||
pure (remote lang (Step (Local (Receive chan))))
|
Mux.debug $ "ReceiveAsync force channel " ++ show forceChan
|
||||||
runLocal (Receive (Channel cid)) = do
|
let micros = floor $ seconds * 1000 * 1000
|
||||||
Mux.debug $ "runLocal Receive " ++ show cid
|
force <- Mux.receiveTimed' ("receiveAsync on " ++ show chan)
|
||||||
(recv,_) <- Mux.receiveCancellable (Mux.Channel Mux.Type cid)
|
micros ((Mux.Channel Mux.Type cid) :: Mux.Channel B.ByteString)
|
||||||
bytes <- recv
|
Mux.saveReceive micros (Mux.channelId forceChan) force
|
||||||
|
pure (remote lang (Step (Local (Receive (Channel $ Mux.channelId forceChan)))))
|
||||||
|
runLocal (Receive chan@(Channel cid)) = do
|
||||||
|
Mux.debug $ "runLocal Receive " ++ show chan
|
||||||
|
bytes <- Mux.restoreReceive cid
|
||||||
|
Mux.debug $ "runLocal Receive got bytes " ++ show chan
|
||||||
case Get.runGetS deserialize bytes of
|
case Get.runGetS deserialize bytes of
|
||||||
Left err -> fail err
|
Left err -> fail err
|
||||||
Right r -> pure r
|
Right r -> pure r
|
||||||
@ -233,7 +246,7 @@ client crypto allow env p recipient r = Mux.scope "Remote.client" $ do
|
|||||||
Mux.info $ "connected"
|
Mux.info $ "connected"
|
||||||
replyChan <- Mux.channel
|
replyChan <- Mux.channel
|
||||||
let send' (a,b) = send (Just (a,b))
|
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
|
Mux.debug $ "got ack on " ++ show replyChan
|
||||||
-- todo - might want to retry if ack doesn't come back
|
-- todo - might want to retry if ack doesn't come back
|
||||||
id $
|
id $
|
||||||
|
@ -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
|
|
@ -33,19 +33,26 @@ numlinks = let found = getLinks $ pack testHTML in if 3 == length found
|
|||||||
then pure ()
|
then pure ()
|
||||||
else fail $ "expected 3 links, got " ++ show found
|
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 :: TestTree
|
||||||
tests = testGroup "html"
|
tests = testGroup "html"
|
||||||
[ testCase "numlinks" numlinks
|
[ testCase "numlinks" numlinks
|
||||||
]
|
]
|
||||||
|
|
||||||
-- evaluateTerms :: [(Path, e)] -> Noted m [(Path,e,e)],
|
-- evaluateTerms :: [(Path, e)] -> Noted m [(Path,e,e)],
|
||||||
unisonEvaluate :: TestNode -> Assertion
|
unisonEvaluate :: (TestNode, String -> TermV) -> Assertion
|
||||||
unisonEvaluate testNode = do
|
unisonEvaluate (testNode, parse) = do
|
||||||
let inputPath = [P.Fn]
|
let inputPath = [P.Fn]
|
||||||
getLinksTerm = unsafeParseTerm $ "getLinks \"" ++ testHTML2 ++ "\""
|
getLinksTerm = parse $ "Html.get-links \"" ++ testHTML2 ++ "\""
|
||||||
linkTerm = EB.link (Term.text "link.html") (Term.text "description")
|
linkTerm = EB.link (Term.text "link.html") (Term.text "description")
|
||||||
getLink = Term.ref (R.Builtin "Html.getHref") `Term.app` linkTerm
|
getLink = Term.ref (R.Builtin "Html.get-href") `Term.app` linkTerm
|
||||||
getDescription = Term.ref (R.Builtin "Html.getDescription") `Term.app` linkTerm
|
getDescription = Term.ref (R.Builtin "Html.get-description") `Term.app` linkTerm
|
||||||
desiredLinks = Term.vector [linkTerm]
|
desiredLinks = Term.vector [linkTerm]
|
||||||
desiredHref = Term.text "link.html"
|
desiredHref = Term.text "link.html"
|
||||||
desiredDescription = Term.text "description"
|
desiredDescription = Term.text "description"
|
||||||
@ -64,8 +71,14 @@ unisonEvaluate testNode = do
|
|||||||
, "description match ", show (description == desiredDescription)
|
, "description match ", show (description == desiredDescription)
|
||||||
]
|
]
|
||||||
|
|
||||||
nodeTests :: TestNode -> TestTree
|
nodeTests :: (TestNode, String -> TermV) -> TestTree
|
||||||
nodeTests testNode = testGroup "html"
|
nodeTests testNode = testGroup "html"
|
||||||
[ testCase "numlinks" numlinks
|
[ testCase "numlinks" numlinks
|
||||||
|
, testCase "plainText" plainText
|
||||||
, testCase "unisonEvaluate" (unisonEvaluate testNode)
|
, testCase "unisonEvaluate" (unisonEvaluate testNode)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
testNode <- makeTestNode
|
||||||
|
defaultMain (nodeTests testNode)
|
||||||
|
@ -2,6 +2,8 @@
|
|||||||
|
|
||||||
module Unison.Test.NodeUtil where
|
module Unison.Test.NodeUtil where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
import Unison.Hash (Hash)
|
import Unison.Hash (Hash)
|
||||||
import Unison.Node (Node)
|
import Unison.Node (Node)
|
||||||
import Unison.Reference (Reference)
|
import Unison.Reference (Reference)
|
||||||
@ -10,21 +12,31 @@ import Unison.Symbol (Symbol)
|
|||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Var (Var)
|
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.ABT as ABT
|
||||||
import qualified Unison.BlockStore.MemBlockStore as MBS
|
import qualified Unison.BlockStore.MemBlockStore as MBS
|
||||||
import qualified Unison.Cryptography as C
|
import qualified Unison.Cryptography as C
|
||||||
import qualified Unison.Hash as Hash
|
import qualified Unison.Hash as Hash
|
||||||
|
import qualified Unison.Node as Node
|
||||||
import qualified Unison.Node.BasicNode as BasicNode
|
import qualified Unison.Node.BasicNode as BasicNode
|
||||||
import qualified Unison.Node.Builtin as Builtin
|
import qualified Unison.Node.Builtin as Builtin
|
||||||
|
import qualified Unison.Node.FileStore as FS
|
||||||
import qualified Unison.Node.UnisonBlockStore as UBS
|
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 R
|
||||||
import qualified Unison.Reference as Reference
|
import qualified Unison.Reference as Reference
|
||||||
import qualified Unison.Runtime.ExtraBuiltins as EB
|
import qualified Unison.Runtime.ExtraBuiltins as EB
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
import qualified Unison.View as View
|
import qualified Unison.View as View
|
||||||
|
import qualified Unison.Util.Logger as L
|
||||||
|
|
||||||
type DFO = View.DFO
|
type DFO = View.DFO
|
||||||
type V = Symbol DFO
|
type V = Symbol DFO
|
||||||
|
type TermV = Term V
|
||||||
type TestNode = Node IO V R.Reference (Type V) (Term V)
|
type TestNode = Node IO V R.Reference (Type V) (Term V)
|
||||||
|
|
||||||
hash :: Var v => Term.Term v -> Reference
|
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 :: C.Cryptography k syk sk skp s h c -> IO Address
|
||||||
makeRandomAddress crypt = Address <$> C.randomBytes crypt 64
|
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
|
makeTestNode = do
|
||||||
|
logger <- L.atomic (L.atInfo L.toStandardOut)
|
||||||
let crypto = C.noop "dummypublickey"
|
let crypto = C.noop "dummypublickey"
|
||||||
|
putStrLn "creating block store..."
|
||||||
blockStore <- MBS.make' (makeRandomAddress crypto) makeAddress
|
blockStore <- MBS.make' (makeRandomAddress crypto) makeAddress
|
||||||
|
putStrLn "created block store, creating Node store..."
|
||||||
store' <- UBS.make blockStore
|
store' <- UBS.make blockStore
|
||||||
keyValueOps <- EB.makeAPI blockStore crypto
|
-- store' <- FS.make "blockstore.file"
|
||||||
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
|
putStrLn "created Node store..., building extra builtins"
|
||||||
BasicNode.make hash store' makeBuiltins
|
extraBuiltins <- EB.make logger blockStore crypto
|
||||||
|
putStrLn "extra builtins created"
|
||||||
|
let makeBuiltins whnf = concat [Builtin.makeBuiltins logger whnf, extraBuiltins whnf]
|
||||||
|
node <- BasicNode.make hash store' makeBuiltins
|
||||||
|
L.info logger "Node created"
|
||||||
|
loadDeclarations logger "unison-src/base.u" node
|
||||||
|
loadDeclarations logger "unison-src/extra.u" node
|
||||||
|
builtins <- Note.run $ Node.allTermsByVarName Term.ref node
|
||||||
|
let parse = Parsers.bindBuiltins builtins [] . Parsers.unsafeParseTerm
|
||||||
|
pure (node, parse)
|
||||||
|
@ -26,10 +26,10 @@ lambda :: Assertion
|
|||||||
lambda = testTermString "x -> x"
|
lambda = testTermString "x -> x"
|
||||||
|
|
||||||
letBinding :: Assertion
|
letBinding :: Assertion
|
||||||
letBinding = testTermString "let x = 42 in x + 1"
|
letBinding = testTermString "let x = 42; x + 1;;"
|
||||||
|
|
||||||
letRec :: Assertion
|
letRec :: Assertion
|
||||||
letRec = testTermString "let rec x = x + 1 in x"
|
letRec = testTermString "let rec x = x + 1; x;;"
|
||||||
|
|
||||||
vec :: Assertion
|
vec :: Assertion
|
||||||
vec = testTermString "[\"a\", \"b\", \"c\"]"
|
vec = testTermString "[\"a\", \"b\", \"c\"]"
|
||||||
@ -43,5 +43,4 @@ tests = testGroup "SerializationAndHashing"
|
|||||||
, testCase "letBinding" letBinding
|
, testCase "letBinding" letBinding
|
||||||
, testCase "letRec" letRec
|
, testCase "letRec" letRec
|
||||||
, testCase "vec" vec
|
, testCase "vec" vec
|
||||||
|
|
||||||
]
|
]
|
||||||
|
@ -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;
|
|
||||||
}
|
|
@ -50,10 +50,10 @@ library
|
|||||||
Unison.Hash.Extra
|
Unison.Hash.Extra
|
||||||
Unison.Kind.Extra
|
Unison.Kind.Extra
|
||||||
Unison.Metadata.Extra
|
Unison.Metadata.Extra
|
||||||
|
Unison.Node.FileStore
|
||||||
Unison.Node.UnisonBlockStore
|
Unison.Node.UnisonBlockStore
|
||||||
Unison.NodeContainer
|
Unison.NodeContainer
|
||||||
Unison.NodeServer
|
Unison.NodeServer
|
||||||
Unison.NodeWorker
|
|
||||||
Unison.NodeProtocol
|
Unison.NodeProtocol
|
||||||
Unison.NodeProtocol.V0
|
Unison.NodeProtocol.V0
|
||||||
Unison.Reference.Extra
|
Unison.Reference.Extra
|
||||||
@ -119,6 +119,7 @@ library
|
|||||||
mtl,
|
mtl,
|
||||||
murmur-hash,
|
murmur-hash,
|
||||||
network,
|
network,
|
||||||
|
network-uri,
|
||||||
network-simple,
|
network-simple,
|
||||||
prelude-extras,
|
prelude-extras,
|
||||||
process,
|
process,
|
||||||
@ -149,47 +150,10 @@ library
|
|||||||
|
|
||||||
if flag(leveldb)
|
if flag(leveldb)
|
||||||
build-depends: exceptions, leveldb-haskell
|
build-depends: exceptions, leveldb-haskell
|
||||||
|
cpp-options: -Dleveldb
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Unison.BlockStore.LevelDbStore
|
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
|
executable container
|
||||||
main-is: Container.hs
|
main-is: Container.hs
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
@ -222,11 +186,13 @@ executable container
|
|||||||
memory,
|
memory,
|
||||||
mmorph,
|
mmorph,
|
||||||
mtl,
|
mtl,
|
||||||
|
network-uri,
|
||||||
process,
|
process,
|
||||||
safecopy,
|
safecopy,
|
||||||
scotty,
|
scotty,
|
||||||
stm,
|
stm,
|
||||||
stm-containers,
|
stm-containers,
|
||||||
|
tagsoup,
|
||||||
text,
|
text,
|
||||||
time,
|
time,
|
||||||
transformers,
|
transformers,
|
||||||
@ -237,8 +203,35 @@ executable container
|
|||||||
wai-extra,
|
wai-extra,
|
||||||
wai-middleware-static
|
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)
|
if flag(leveldb)
|
||||||
build-depends: exceptions, leveldb-haskell
|
build-depends: exceptions, leveldb-haskell
|
||||||
|
cpp-options: -Dleveldb
|
||||||
|
|
||||||
executable node
|
executable node
|
||||||
main-is: Node.hs
|
main-is: Node.hs
|
||||||
@ -273,6 +266,7 @@ executable node
|
|||||||
memory,
|
memory,
|
||||||
mtl,
|
mtl,
|
||||||
murmur-hash,
|
murmur-hash,
|
||||||
|
network-uri,
|
||||||
prelude-extras,
|
prelude-extras,
|
||||||
random,
|
random,
|
||||||
safecopy,
|
safecopy,
|
||||||
@ -288,6 +282,29 @@ executable node
|
|||||||
vector,
|
vector,
|
||||||
wai-extra,
|
wai-extra,
|
||||||
wai-middleware-static
|
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)
|
if flag(leveldb)
|
||||||
build-depends: exceptions, leveldb-haskell
|
build-depends: exceptions, leveldb-haskell
|
||||||
@ -308,6 +325,7 @@ test-suite tests
|
|||||||
ctrie,
|
ctrie,
|
||||||
curl,
|
curl,
|
||||||
directory,
|
directory,
|
||||||
|
filepath,
|
||||||
hashable,
|
hashable,
|
||||||
random,
|
random,
|
||||||
stm,
|
stm,
|
||||||
@ -321,6 +339,16 @@ test-suite tests
|
|||||||
unison-node,
|
unison-node,
|
||||||
unison-shared,
|
unison-shared,
|
||||||
vector
|
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)
|
if flag(leveldb)
|
||||||
build-depends: exceptions, leveldb-haskell
|
build-depends: exceptions, leveldb-haskell
|
||||||
|
@ -222,14 +222,24 @@ freshNamed' used n = fresh' used (v' n)
|
|||||||
-- | `subst v e body` substitutes `e` for `v` in `body`, avoiding capture by
|
-- | `subst v e body` substitutes `e` for `v` in `body`, avoiding capture by
|
||||||
-- renaming abstractions in `body`
|
-- 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 :: (Foldable f, Functor f, Var v) => v -> Term f v a -> Term f v a -> Term f v a
|
||||||
subst v = replace match where
|
subst v r t2@(Term fvs ann body)
|
||||||
match (Var' v') = v == v'
|
| Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped
|
||||||
match _ = False
|
| otherwise = case body of
|
||||||
|
Var v' | v == v' -> r -- var match; perform replacement
|
||||||
|
| otherwise -> t2 -- var did not match one being substituted; ignore
|
||||||
|
Cycle body -> cycle' ann (subst v r body)
|
||||||
|
Abs x e | x == v -> t2 -- x shadows v; ignore subtree
|
||||||
|
Abs x e -> abs' ann x' e'
|
||||||
|
where x' = freshInBoth r t2 x
|
||||||
|
-- rename x to something that cannot be captured by `r`
|
||||||
|
e' = if x /= x' then subst v r (rename x x' e)
|
||||||
|
else subst v r e
|
||||||
|
Tm body -> tm' ann (fmap (subst v r) body)
|
||||||
|
|
||||||
-- | `substs [(t1,v1), (t2,v2), ...] body` performs multiple simultaneous
|
-- | `substs [(t1,v1), (t2,v2), ...] body` performs multiple simultaneous
|
||||||
-- substitutions, avoiding capture
|
-- substitutions, avoiding capture
|
||||||
substs :: (Foldable f, Functor f, Var v) => [(v, Term f v a)] -> Term f v a -> Term f v a
|
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
|
f (v, t) body = subst v t body
|
||||||
|
|
||||||
-- | `replace f t body` substitutes `t` for all maximal (outermost)
|
-- | `replace f t body` substitutes `t` for all maximal (outermost)
|
||||||
|
@ -1,14 +1,18 @@
|
|||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
|
||||||
-- | Very simple and inefficient interpreter of Unison terms
|
-- | Very simple and inefficient interpreter of Unison terms
|
||||||
module Unison.Eval.Interpreter where
|
module Unison.Eval.Interpreter where
|
||||||
|
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
|
import Data.List
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Unison.Eval
|
import Unison.Eval
|
||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Text as Text
|
||||||
import qualified Unison.ABT as ABT
|
import qualified Unison.ABT as ABT
|
||||||
import qualified Unison.Reference as R
|
import qualified Unison.Reference as R
|
||||||
import qualified Unison.Term as E
|
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
|
eval env = Eval whnf step
|
||||||
where
|
where
|
||||||
-- reduce x args | trace ("reduce:" ++ show (x:args)) False = undefined
|
-- reduce x args | trace ("reduce:" ++ show (x:args)) False = undefined
|
||||||
reduce :: Term v -> [Term v] -> f (Maybe (Term v))
|
reduce resolveRef (E.Ann' e _) args = reduce resolveRef e args
|
||||||
reduce (E.Lam' _) [] = pure Nothing
|
reduce resolveRef (E.App' f x) args = do
|
||||||
reduce (E.Lam' f) (arg1:args) =
|
x <- whnf resolveRef x
|
||||||
let r = ABT.bind f arg1
|
reduce resolveRef f (x:args)
|
||||||
in pure $ Just (foldl E.app r args)
|
reduce resolveRef (E.Let1' binding body) xs = do
|
||||||
reduce (E.Ref' h) args = case M.lookup h env of
|
binding <- whnf resolveRef binding
|
||||||
Nothing -> pure Nothing
|
reduce resolveRef (ABT.bind body binding) xs
|
||||||
|
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 ->
|
Just op | length args >= arity op ->
|
||||||
call op (take (arity op) args) >>= \e ->
|
call op (take (arity op) args) >>= \e ->
|
||||||
pure . Just $ foldl E.app e (drop (arity op) args)
|
pure . Just $ foldl E.app e (drop (arity op) args)
|
||||||
Just _ | otherwise -> pure Nothing
|
Just _ | otherwise -> pure Nothing
|
||||||
reduce (E.App' f x) args = reduce f (x:args)
|
E.LamsNamed' vs body -> let n = length vs in case args of
|
||||||
reduce (E.Let1' binding body) xs = reduce (ABT.bind body binding) xs
|
[] -> pure Nothing
|
||||||
reduce _ _ = 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
|
step resolveRef e = case e of
|
||||||
|
E.Ann' e _ -> step resolveRef e
|
||||||
E.Ref' h -> case M.lookup h env of
|
E.Ref' h -> case M.lookup h env of
|
||||||
Just op | arity op == 0 -> call op []
|
Just op | arity op == 0 -> call op []
|
||||||
_ -> pure e
|
_ -> pure e
|
||||||
E.App' (E.LetRecNamed' bs body) x -> step resolveRef (E.letRec bs (body `E.app` x))
|
E.Apps' f xs -> do
|
||||||
E.App' f x -> do
|
e' <- reduce resolveRef f xs
|
||||||
f' <- E.link resolveRef f
|
|
||||||
e' <- reduce f' [x]
|
|
||||||
maybe (pure e) pure e'
|
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.Let1' binding body -> step resolveRef (ABT.bind body binding)
|
||||||
E.LetRecNamed' bs body -> step resolveRef (ABT.substs substs body) where
|
E.LetRecNamed' bs body -> step resolveRef (ABT.substs substs body) where
|
||||||
expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
|
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
|
whnf resolveRef e = case e of
|
||||||
E.Ref' h -> case M.lookup h env of
|
E.Ref' h -> case M.lookup h env of
|
||||||
Just op | arity op == 0 -> call op []
|
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.Ann' e _ -> whnf resolveRef e
|
||||||
E.App' (E.Ann' f _) x -> whnf resolveRef (f `E.app` x)
|
E.Apps' E.If' (cond:t:f:tl) -> do
|
||||||
E.App' (E.LetRecNamed' bs body) x -> whnf resolveRef (E.letRec bs (body `E.app` x))
|
cond <- whnf resolveRef cond
|
||||||
E.App' (E.Let1Named' v b body) x -> whnf resolveRef (E.let1 [(v,b)] (body `E.app` x))
|
case cond of
|
||||||
E.App' f x -> do
|
E.Builtin' b | Text.head b == 'F' -> whnf resolveRef f >>= \f -> (`E.apps` tl) <$> whnf resolveRef f
|
||||||
f' <- E.link resolveRef f
|
| otherwise -> whnf resolveRef t >>= \t -> (`E.apps` tl) <$> whnf resolveRef t
|
||||||
e' <- reduce f' [x]
|
_ -> pure e
|
||||||
maybe (pure e) (whnf resolveRef) e'
|
E.Apps' f xs -> do
|
||||||
E.Let1' binding body -> whnf resolveRef (ABT.bind body binding)
|
xs <- traverse (whnf resolveRef) xs
|
||||||
E.LetRecNamed' bs body -> whnf resolveRef (ABT.substs substs body) where
|
f <- whnf resolveRef f
|
||||||
expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
|
e' <- reduce resolveRef f xs
|
||||||
expandBinding v body = ABT.substs substs' body
|
maybe (pure $ f `E.apps` xs) (whnf resolveRef) e'
|
||||||
where substs' = [ (v', ABT.subst v (E.letRec bs (E.var v)) b) | (v',b) <- bs ]
|
E.Let1' binding body -> do
|
||||||
substs = [ (v, expandBinding v b) | (v,b) <- bs ]
|
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 = E.letRec bs body
|
||||||
|
E.Vector' es -> E.vector' <$> traverse (whnf resolveRef) es
|
||||||
_ -> pure e
|
_ -> pure e
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
module Unison.Metadata where
|
module Unison.Metadata where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Aeson.TH
|
import Data.Aeson.TH
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
@ -19,6 +20,11 @@ data Metadata v h =
|
|||||||
description :: Maybe h
|
description :: Maybe h
|
||||||
} deriving (Eq,Ord,Show,Generic)
|
} 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 :: Var v => Query -> Metadata v h -> Bool
|
||||||
matches (Query txt) (Metadata _ (Names ns) _) =
|
matches (Query txt) (Metadata _ (Names ns) _) =
|
||||||
any (Text.isPrefixOf txt) (map Var.name ns)
|
any (Text.isPrefixOf txt) (map Var.name ns)
|
||||||
@ -31,9 +37,16 @@ synthetic t = Metadata t (Names []) Nothing
|
|||||||
syntheticTerm :: Metadata v h
|
syntheticTerm :: Metadata v h
|
||||||
syntheticTerm = synthetic Term
|
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
|
instance Show Query where
|
||||||
show (Query q) = show q
|
show (Query q) = show q
|
||||||
|
@ -1,9 +1,11 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Unison.Node where
|
module Unison.Node where
|
||||||
|
|
||||||
-- import Data.Bytes.Serial (Serial)
|
-- import Data.Bytes.Serial (Serial)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Applicative
|
||||||
import Data.Aeson.TH
|
import Data.Aeson.TH
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
@ -12,7 +14,7 @@ import Data.Set (Set)
|
|||||||
import Unison.Eval as Eval
|
import Unison.Eval as Eval
|
||||||
import Unison.Metadata (Metadata)
|
import Unison.Metadata (Metadata)
|
||||||
import Unison.Node.Store (Store)
|
import Unison.Node.Store (Store)
|
||||||
import Unison.Note (Noted)
|
import Unison.Note (Noted(..),Note(..))
|
||||||
import Unison.Paths (Path)
|
import Unison.Paths (Path)
|
||||||
import Unison.Reference (Reference)
|
import Unison.Reference (Reference)
|
||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
@ -23,11 +25,17 @@ import qualified Data.Map as Map
|
|||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Unison.Metadata as Metadata
|
import qualified Unison.Metadata as Metadata
|
||||||
import qualified Unison.Node.Store as Store
|
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.Paths as Paths
|
||||||
import qualified Unison.Reference as Reference
|
import qualified Unison.Reference as Reference
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
import qualified Unison.TermEdit as TermEdit
|
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 as Typechecker
|
||||||
|
import qualified Unison.Typechecker.Components as Components
|
||||||
|
-- import Debug.Trace
|
||||||
|
|
||||||
-- | The results of a search.
|
-- | The results of a search.
|
||||||
-- On client, only need to repeat the query if we modify a character
|
-- On client, only need to repeat the query if we modify a character
|
||||||
@ -117,8 +125,11 @@ node eval hash store =
|
|||||||
Reference.Builtin _ ->
|
Reference.Builtin _ ->
|
||||||
Store.writeMetadata store r md -- can't change builtin types, just metadata
|
Store.writeMetadata store r md -- can't change builtin types, just metadata
|
||||||
Reference.Derived h -> do
|
Reference.Derived h -> do
|
||||||
|
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.writeTerm store h e
|
||||||
Store.writeMetadata store r md
|
|
||||||
Store.annotateTerm store r t
|
Store.annotateTerm store r t
|
||||||
|
|
||||||
createType _ _ = error "todo - createType"
|
createType _ _ = error "todo - createType"
|
||||||
@ -230,3 +241,46 @@ node eval hash store =
|
|||||||
types
|
types
|
||||||
typeAt
|
typeAt
|
||||||
updateMetadata
|
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
|
||||||
|
@ -2,27 +2,20 @@
|
|||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Unison.Node.BasicNode where
|
module Unison.Node.BasicNode where
|
||||||
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Unison.Metadata (Metadata(..))
|
|
||||||
import Unison.Node (Node)
|
import Unison.Node (Node)
|
||||||
import Unison.Node.Store (Store)
|
import Unison.Node.Store (Store)
|
||||||
import Unison.Parsers (unsafeParseTerm)
|
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.Text as Text
|
|
||||||
import qualified Unison.Eval as Eval
|
import qualified Unison.Eval as Eval
|
||||||
import qualified Unison.Eval.Interpreter as I
|
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 as Node
|
||||||
import qualified Unison.Node.Builtin as B
|
import qualified Unison.Node.Builtin as B
|
||||||
import qualified Unison.Node.Store as Store
|
import qualified Unison.Node.Store as Store
|
||||||
import qualified Unison.Note as N
|
import qualified Unison.Note as N
|
||||||
import qualified Unison.Reference as R
|
import qualified Unison.Reference as R
|
||||||
import qualified Unison.Type as Type
|
import qualified Unison.Type as Type
|
||||||
import qualified Unison.Var as Var
|
|
||||||
import qualified Unison.View as View
|
import qualified Unison.View as View
|
||||||
|
|
||||||
infixr 7 -->
|
infixr 7 -->
|
||||||
@ -43,28 +36,7 @@ make hash store getBuiltins =
|
|||||||
readTerm h = Store.readTerm store h
|
readTerm h = Store.readTerm store h
|
||||||
whnf = Eval.whnf eval readTerm
|
whnf = Eval.whnf eval readTerm
|
||||||
node = Node.node eval hash store
|
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
|
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)
|
mapM_ (\(B.Builtin r _ t md) -> Node.updateMetadata node r md *> Store.annotateTerm store r t)
|
||||||
builtins
|
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
|
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
|
|
||||||
|
@ -1,6 +1,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Unison.Node.Builtin where
|
module Unison.Node.Builtin where
|
||||||
|
|
||||||
|
import Data.List
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Unison.Metadata (Metadata(..))
|
import Unison.Metadata (Metadata(..))
|
||||||
import Unison.Parsers (unsafeParseType)
|
import Unison.Parsers (unsafeParseType)
|
||||||
@ -8,6 +9,8 @@ import Unison.Symbol (Symbol)
|
|||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Typechecker.Context (remoteSignatureOf)
|
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.Vector as Vector
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Unison.ABT as ABT
|
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.Type as Type
|
||||||
import qualified Unison.Var as Var
|
import qualified Unison.Var as Var
|
||||||
import qualified Unison.View as View
|
import qualified Unison.View as View
|
||||||
|
import qualified Unison.Util.Logger as L
|
||||||
|
|
||||||
type DFO = View.DFO
|
type DFO = View.DFO
|
||||||
type V = Symbol DFO
|
type V = Symbol DFO
|
||||||
@ -35,9 +39,16 @@ data Builtin = Builtin
|
|||||||
|
|
||||||
unitRef :: Ord v => Term v
|
unitRef :: Ord v => Term v
|
||||||
unitRef = Term.ref (R.Builtin "()")
|
unitRef = Term.ref (R.Builtin "()")
|
||||||
|
true, false :: Ord v => Term v
|
||||||
|
true = Term.builtin "True"
|
||||||
|
false = Term.builtin "False"
|
||||||
|
pair :: Ord v => Term v
|
||||||
|
pair = Term.builtin "Pair"
|
||||||
|
pair' :: Ord v => Term v -> Term v -> Term v
|
||||||
|
pair' t1 t2 = pair `Term.app` t1 `Term.app` (pair `Term.app` t2 `Term.app` unitRef)
|
||||||
|
|
||||||
makeBuiltins :: WHNFEval -> [Builtin]
|
makeBuiltins :: Logger -> WHNFEval -> [Builtin]
|
||||||
makeBuiltins whnf =
|
makeBuiltins logger whnf =
|
||||||
let
|
let
|
||||||
numeric2 :: Term V -> (Double -> Double -> Double) -> I.Primop (N.Noted IO) V
|
numeric2 :: Term V -> (Double -> Double -> Double) -> I.Primop (N.Noted IO) V
|
||||||
numeric2 sym f = I.Primop 2 $ \xs -> case xs of
|
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
|
numericCompare sym f = I.Primop 2 $ \xs -> case xs of
|
||||||
[x,y] -> g <$> whnf x <*> whnf y
|
[x,y] -> g <$> whnf x <*> whnf y
|
||||||
where g (Term.Number' x) (Term.Number' y) = case f x y of
|
where g (Term.Number' x) (Term.Number' y) = case f x y of
|
||||||
False -> Term.builtin "False"
|
False -> false
|
||||||
True -> Term.builtin "True"
|
True -> true
|
||||||
g x y = sym `Term.app` x `Term.app` y
|
g x y = sym `Term.app` x `Term.app` y
|
||||||
_ -> error "unpossible"
|
_ -> 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 :: Term V -> (Text -> Text -> Text) -> I.Primop (N.Noted IO) V
|
||||||
string2 sym f = I.Primop 2 $ \xs -> case xs of
|
string2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||||
[x,y] -> g <$> whnf x <*> whnf y
|
[x,y] -> g <$> whnf x <*> whnf y
|
||||||
where g (Term.Text' x) (Term.Text' y) = Term.lit (Term.Text (f x 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
|
g x y = sym `Term.app` x `Term.app` y
|
||||||
_ -> error "unpossible"
|
_ -> 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)
|
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 "()")
|
in (r, Nothing, unitT, prefix "()")
|
||||||
|
, let r = R.Builtin "Unit.Order"
|
||||||
|
in (r, Nothing, unsafeParseType "Order Unit", prefix "Unit.Order")
|
||||||
|
|
||||||
, let r = R.Builtin "Color.rgba"
|
-- debugging printlns
|
||||||
in (r, strict r 4, unsafeParseType "Number -> Number -> Number -> Number -> Color", prefix "rgba")
|
, let r = R.Builtin "Debug.log";
|
||||||
|
op [msg,logged,a] = do
|
||||||
|
Term.Text' msg <- whnf msg
|
||||||
|
logged <- whnf logged
|
||||||
|
N.lift $ L.error logger (Text.unpack msg ++ ": " ++ show logged)
|
||||||
|
whnf a
|
||||||
|
op _ = error "unpossible"
|
||||||
|
typ = "∀ a b . Text -> a -> b -> b"
|
||||||
|
in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "Debug.log")
|
||||||
|
|
||||||
-- booleans
|
, let r = R.Builtin "Debug.watch";
|
||||||
|
op [msg,a] = do
|
||||||
|
Term.Text' msg <- whnf msg
|
||||||
|
a <- whnf a
|
||||||
|
N.lift $ L.error logger (Text.unpack msg ++ ": " ++ show a)
|
||||||
|
pure a
|
||||||
|
op _ = error "unpossible"
|
||||||
|
typ = "∀ a . Text -> a -> a"
|
||||||
|
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Debug.watch")
|
||||||
|
|
||||||
|
-- Boolean
|
||||||
, let r = R.Builtin "True"
|
, let r = R.Builtin "True"
|
||||||
in (r, Nothing, Type.builtin "Boolean", prefix "True")
|
in (r, Nothing, Type.builtin "Boolean", prefix "True")
|
||||||
, let r = R.Builtin "False";
|
, let r = R.Builtin "False";
|
||||||
in (r, Nothing, Type.builtin "Boolean", prefix "False")
|
in (r, Nothing, Type.builtin "Boolean", prefix "False")
|
||||||
, let r = R.Builtin "Boolean.if";
|
, let r = R.Builtin "Boolean.and";
|
||||||
op [cond,t,f] = do
|
op [b1,b2] = do
|
||||||
cond <- whnf cond
|
Term.Builtin' b1 <- whnf b1
|
||||||
case cond of
|
Term.Builtin' b2 <- whnf b2
|
||||||
Term.Builtin' tf -> case Text.head tf of
|
pure $ case (b1,b2) of
|
||||||
'T' -> whnf t
|
_ | Text.head b1 /= Text.head b2 -> false
|
||||||
'F' -> whnf f
|
| otherwise -> if Text.head b1 == 'T' then true else false
|
||||||
_ -> error "unpossible"
|
|
||||||
_ -> error "unpossible"
|
|
||||||
op _ = error "unpossible"
|
op _ = error "unpossible"
|
||||||
typ = "forall a . Boolean -> a -> a -> a"
|
typ = "Boolean -> Boolean -> Boolean"
|
||||||
in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "if")
|
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "and")
|
||||||
|
, let r = R.Builtin "Boolean.or";
|
||||||
|
op [b1,b2] = do
|
||||||
|
Term.Builtin' b1 <- whnf b1
|
||||||
|
Term.Builtin' b2 <- whnf b2
|
||||||
|
pure $ case (b1,b2) of
|
||||||
|
_ | Text.head b1 /= Text.head b2 -> true
|
||||||
|
| otherwise -> if Text.head b1 == 'F' then false else true
|
||||||
|
op _ = error "unpossible"
|
||||||
|
typ = "Boolean -> Boolean -> Boolean"
|
||||||
|
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "or")
|
||||||
|
, let r = R.Builtin "Boolean.not";
|
||||||
|
op [b1] = do
|
||||||
|
Term.Builtin' b1 <- whnf b1
|
||||||
|
pure $ if Text.head b1 == 'T' then false else true
|
||||||
|
op _ = error "unpossible"
|
||||||
|
typ = "Boolean -> Boolean"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "not")
|
||||||
|
|
||||||
-- numbers
|
-- Number
|
||||||
, let r = R.Builtin "Number.plus"
|
, let r = R.Builtin "Number.+"
|
||||||
in (r, Just (numeric2 (Term.ref r) (+)), numOpTyp, assoc 4 "+")
|
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 "-")
|
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 "*")
|
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 "/")
|
in (r, Just (numeric2 (Term.ref r) (/)), numOpTyp, opl 5 "/")
|
||||||
, let r = R.Builtin "Number.greaterThan"
|
, let r = R.Builtin "Number.>"
|
||||||
in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 ">")
|
in (r, Just (numericCompare (Term.ref r) (>)), numCompareTyp, opl 3 "Number.>")
|
||||||
, let r = R.Builtin "Number.lessThan"
|
, let r = R.Builtin "Number.<"
|
||||||
in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "<")
|
in (r, Just (numericCompare (Term.ref r) (<)), numCompareTyp, opl 3 "Number.<")
|
||||||
, let r = R.Builtin "Number.greaterThanOrEqual"
|
, let r = R.Builtin "Number.>="
|
||||||
in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 ">=")
|
in (r, Just (numericCompare (Term.ref r) (>=)), numCompareTyp, opl 3 "Number.>=")
|
||||||
, let r = R.Builtin "Number.lessThanOrEqual"
|
, let r = R.Builtin "Number.<="
|
||||||
in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "<=")
|
in (r, Just (numericCompare (Term.ref r) (<=)), numCompareTyp, opl 3 "Number.<=")
|
||||||
, let r = R.Builtin "Number.equal"
|
, let r = R.Builtin "Number.=="
|
||||||
in (r, Just (numericCompare (Term.ref r) (==)), numCompareTyp, opl 3 "==")
|
in (r, Just (numericCompare (Term.ref r) (==)), numCompareTyp, opl 3 "Number.==")
|
||||||
|
, let r = R.Builtin "Number.Order"
|
||||||
|
in (r, Nothing, unsafeParseType "Order Number", prefix "Number.Order")
|
||||||
|
|
||||||
-- remote computations
|
-- Duration
|
||||||
|
, let r = R.Builtin "Duration.seconds"
|
||||||
|
op [n] = do
|
||||||
|
Term.Number' n <- whnf n
|
||||||
|
pure $ Term.num n
|
||||||
|
op _ = fail "Duration.seconds unpossible"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType "Number -> Duration", prefix "Duration.seconds")
|
||||||
|
|
||||||
|
-- Remote
|
||||||
|
, let r = R.Builtin "Remote.sleep"
|
||||||
|
op [seconds] = do
|
||||||
|
Term.Number' seconds <- whnf seconds
|
||||||
|
let s = Remote.Seconds seconds
|
||||||
|
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Sleep s)))
|
||||||
|
op _ = fail "Remote.sleep unpossible"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType "Duration -> Remote Unit", prefix "Remote.sleep")
|
||||||
, let r = R.Builtin "Remote.at"
|
, let r = R.Builtin "Remote.at"
|
||||||
op [node,term] = do
|
op [node,term] = do
|
||||||
Term.Distributed' (Term.Node node) <- whnf node
|
Term.Distributed' (Term.Node node) <- whnf node
|
||||||
pure $ Term.remote (Remote.Step (Remote.At node term))
|
pure $ Term.remote (Remote.Step (Remote.At node term))
|
||||||
op _ = fail "Remote.at unpossible"
|
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"
|
, let r = R.Builtin "Remote.here"
|
||||||
op [] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Here)))
|
op [] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Here)))
|
||||||
op _ = fail "Remote.here unpossible"
|
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"
|
, let r = R.Builtin "Remote.spawn"
|
||||||
op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.Spawn))
|
op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.Spawn))
|
||||||
op _ = fail "Remote.spawn unpossible"
|
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"
|
, let r = R.Builtin "Remote.send"
|
||||||
op [c, v] = do
|
op [c, v] = do
|
||||||
Term.Distributed' (Term.Channel c) <- whnf c
|
Term.Distributed' (Term.Channel c) <- whnf c
|
||||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Send c v)))
|
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Send c v)))
|
||||||
op _ = fail "Remote.send unpossible"
|
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"
|
, let r = R.Builtin "Remote.channel"
|
||||||
op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.CreateChannel))
|
op [] = pure $ Term.remote (Remote.Step (Remote.Local Remote.CreateChannel))
|
||||||
op _ = fail "Remote.channel unpossible"
|
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"
|
, let r = R.Builtin "Remote.bind"
|
||||||
op [g, r] = do
|
op [g, r] = do
|
||||||
r <- whnf r
|
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.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))
|
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
|
_ -> fail $ "Remote.bind given a value that was not a Remote: " ++ show r
|
||||||
|
++ " "
|
||||||
|
++ show (ABT.freeVars r)
|
||||||
op _ = fail "Remote.bind unpossible"
|
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"
|
, let r = R.Builtin "Remote.pure"
|
||||||
op [a] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Pure a)))
|
op [a] = pure $ Term.remote (Remote.Step (Remote.Local (Remote.Pure a)))
|
||||||
op _ = fail "unpossible"
|
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"
|
, let r = R.Builtin "Remote.map"
|
||||||
op [f, r] = pure $ Term.builtin "Remote.bind" `Term.app`
|
op [f, r] = pure $ Term.builtin "Remote.bind" `Term.app`
|
||||||
(Term.lam' ["x"] $ Term.remote
|
(Term.lam' ["x"] $ Term.remote
|
||||||
(Remote.Step . Remote.Local . Remote.Pure $ f `Term.app` Term.var' "x"))
|
(Remote.Step . Remote.Local . Remote.Pure $ f `Term.app` Term.var' "x"))
|
||||||
`Term.app` r
|
`Term.app` r
|
||||||
op _ = fail "unpossible"
|
op _ = fail "unpossible"
|
||||||
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "map")
|
in (r, Just (I.Primop 2 op), remoteSignatureOf "Remote.map", prefix "Remote.map")
|
||||||
, let r = R.Builtin "Remote.receiveAsync"
|
, let r = R.Builtin "Remote.receive-async"
|
||||||
op [chan, timeout] = do
|
op [chan, timeout] = do
|
||||||
Term.Number' seconds <- whnf timeout
|
Term.Number' seconds <- whnf timeout
|
||||||
Term.Distributed' (Term.Channel chan) <- whnf chan
|
Term.Distributed' (Term.Channel chan) <- whnf chan
|
||||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.ReceiveAsync chan (Remote.Seconds seconds))))
|
pure $ Term.remote (Remote.Step (Remote.Local (Remote.ReceiveAsync chan (Remote.Seconds seconds))))
|
||||||
op _ = fail "unpossible"
|
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"
|
, let r = R.Builtin "Remote.receive"
|
||||||
op [chan] = do
|
op [chan] = do
|
||||||
Term.Distributed' (Term.Channel chan) <- whnf chan
|
Term.Distributed' (Term.Channel chan) <- whnf chan
|
||||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Receive chan)))
|
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Receive chan)))
|
||||||
op _ = fail "unpossible"
|
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"
|
, let r = R.Builtin "Remote.fork"
|
||||||
op [r] = do
|
op [r] = do
|
||||||
Term.Distributed' (Term.Remote r) <- whnf r
|
Term.Distributed' (Term.Remote r) <- whnf r
|
||||||
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Fork r)))
|
pure $ Term.remote (Remote.Step (Remote.Local (Remote.Fork r)))
|
||||||
op _ = fail "unpossible"
|
op _ = fail "unpossible"
|
||||||
in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.fork", prefix "fork")
|
in (r, Just (I.Primop 1 op), remoteSignatureOf "Remote.fork", prefix "Remote.fork")
|
||||||
|
|
||||||
, let r = R.Builtin "Symbol.Symbol"
|
|
||||||
in (r, Nothing, unsafeParseType "Text -> Fixity -> Number -> Symbol", prefix "Symbol")
|
|
||||||
|
|
||||||
|
-- Text
|
||||||
, let r = R.Builtin "Text.concatenate"
|
, let r = R.Builtin "Text.concatenate"
|
||||||
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefixes ["concatenate", "Text"])
|
in (r, Just (string2 (Term.ref r) mappend), strOpTyp, prefix "Text.concatenate")
|
||||||
, let r = R.Builtin "Text.left"
|
, let r = R.Builtin "Text.=="
|
||||||
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
|
in (r, Just (string2' (Term.ref r) (==)), textCompareTyp, prefix "Text.==")
|
||||||
, let r = R.Builtin "Text.right"
|
, let r = R.Builtin "Text.<"
|
||||||
in (r, Nothing, alignmentT, prefixes ["right", "Text"])
|
in (r, Just (string2' (Term.ref r) (<)), textCompareTyp, prefix "Text.<")
|
||||||
, let r = R.Builtin "Text.center"
|
, let r = R.Builtin "Text.<="
|
||||||
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
|
in (r, Just (string2' (Term.ref r) (<=)), textCompareTyp, prefix "Text.<=")
|
||||||
, let r = R.Builtin "Text.justify"
|
, let r = R.Builtin "Text.>"
|
||||||
in (r, Nothing, alignmentT, prefixes ["justify", "Text"])
|
in (r, Just (string2' (Term.ref r) (>)), textCompareTyp, prefix "Text.>")
|
||||||
|
, let r = R.Builtin "Text.>="
|
||||||
|
in (r, Just (string2' (Term.ref r) (>=)), textCompareTyp, prefix "Text.>=")
|
||||||
|
, let r = R.Builtin "Text.Order"
|
||||||
|
in (r, Nothing, unsafeParseType "Order Text", prefix "Text.Order")
|
||||||
|
, let r = R.Builtin "Text.lowercase"
|
||||||
|
op [Term.Text' txt] = pure $ Term.text (Text.toLower txt)
|
||||||
|
op _ = error "Text.lowercase unpossible"
|
||||||
|
typ = "Text -> Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.lowercase")
|
||||||
|
, let r = R.Builtin "Text.uppercase"
|
||||||
|
op [Term.Text' txt] = pure $ Term.text (Text.toUpper txt)
|
||||||
|
op _ = error "Text.uppercase unpossible"
|
||||||
|
typ = "Text -> Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.lowercase")
|
||||||
|
, let r = R.Builtin "Text.take"
|
||||||
|
op [Term.Number' n, Term.Text' txt] = pure $ Term.text (Text.take (floor n) txt)
|
||||||
|
op _ = error "Text.take unpossible"
|
||||||
|
typ = "Number -> Text -> Text"
|
||||||
|
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Text.take")
|
||||||
|
, let r = R.Builtin "Text.drop"
|
||||||
|
op [Term.Number' n, Term.Text' txt] = pure $ Term.text (Text.drop (floor n) txt)
|
||||||
|
op _ = error "Text.drop unpossible"
|
||||||
|
typ = "Number -> Text -> Text"
|
||||||
|
in (r, Just (I.Primop 2 op), unsafeParseType typ, prefix "Text.drop")
|
||||||
|
, -- todo: rather special purpose, remove this in favor of more generic regex
|
||||||
|
let r = R.Builtin "Text.words"
|
||||||
|
op [Term.Text' txt] = pure $
|
||||||
|
let words = map stripPunctuation $ Text.split Char.isSpace txt
|
||||||
|
stripPunctuation word = Text.dropAround (not . Char.isAlphaNum) word
|
||||||
|
in Term.vector (map Term.text . filter (not . Text.null) $ words)
|
||||||
|
op _ = error "Text.words unpossible"
|
||||||
|
typ = "Text -> Vector Text"
|
||||||
|
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "Text.words")
|
||||||
|
|
||||||
|
-- Pair
|
||||||
|
, let r = R.Builtin "Pair"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a b . a -> b -> Pair a b", prefix "Pair")
|
||||||
|
, let r = R.Builtin "Pair.fold"
|
||||||
|
op [f,p] = do
|
||||||
|
p <- whnf p
|
||||||
|
case p of
|
||||||
|
Term.Apps' (Term.Builtin' "Pair") [a,b] -> whnf (f `Term.apps` [a,b])
|
||||||
|
p -> fail $ "expected pair, got: " ++ show p
|
||||||
|
op _ = error "Pair.fold unpossible"
|
||||||
|
in (r, Just (I.Primop 2 op), unsafeParseType "forall a b c . (a -> b -> c) -> Pair a b -> c", prefix "Pair.fold")
|
||||||
|
, let r = R.Builtin "Pair.Order"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a b . Order a -> Order b -> Order (Pair a b)", prefix "Pair.Order")
|
||||||
|
|
||||||
|
-- Either
|
||||||
|
, let r = R.Builtin "Either.Left"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a b . a -> Either a b", prefix "Left")
|
||||||
|
, let r = R.Builtin "Either.Right"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a b . b -> Either a b", prefix "Right")
|
||||||
|
, let r = R.Builtin "Either.fold"
|
||||||
|
op [fa,fb,e] = do
|
||||||
|
Term.App' (Term.Builtin' tag) aOrB <- whnf e
|
||||||
|
case tag of
|
||||||
|
_ | tag == "Either.Left" -> whnf (fa `Term.app` aOrB)
|
||||||
|
| tag == "Either.Right" -> whnf (fb `Term.app` aOrB)
|
||||||
|
| otherwise -> error "type errror"
|
||||||
|
op _ = error "Either.fold unpossible"
|
||||||
|
in (r, Just (I.Primop 3 op), unsafeParseType "forall a b r . (a -> r) -> (b -> r) -> Either a b -> r", prefix "Either.fold")
|
||||||
|
|
||||||
|
-- Optional
|
||||||
|
, let r = R.Builtin "Optional.None"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a . Optional a", prefix "None")
|
||||||
|
, let r = R.Builtin "Optional.Some"
|
||||||
|
in (r, Nothing, unsafeParseType "forall a . a -> Optional a", prefix "Some")
|
||||||
|
, let r = R.Builtin "Optional.fold"
|
||||||
|
op [fz,f,o] = whnf o >>= \o -> case o of
|
||||||
|
Term.Builtin' tag | tag == "Optional.None" -> whnf fz
|
||||||
|
Term.App' (Term.Builtin' tag) a | tag == "Optional.Some" -> whnf (f `Term.app` a)
|
||||||
|
_ -> error $ "Optional.fold unpossible: " ++ show o
|
||||||
|
op _ = error "Optional.fold unpossible"
|
||||||
|
in (r, Just (I.Primop 3 op), unsafeParseType "forall a r . r -> (a -> r) -> Optional a -> r", prefix "Optional.fold")
|
||||||
|
|
||||||
|
-- Vector
|
||||||
, let r = R.Builtin "Vector.append"
|
, let r = R.Builtin "Vector.append"
|
||||||
op [last,init] = do
|
op [last,init] = do
|
||||||
initr <- whnf init
|
initr <- whnf init
|
||||||
@ -196,7 +338,7 @@ makeBuiltins whnf =
|
|||||||
Term.Vector' init -> Term.vector' (Vector.snoc init last)
|
Term.Vector' init -> Term.vector' (Vector.snoc init last)
|
||||||
init -> Term.ref r `Term.app` last `Term.app` init
|
init -> Term.ref r `Term.app` last `Term.app` init
|
||||||
op _ = fail "Vector.append unpossible"
|
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"
|
, let r = R.Builtin "Vector.concatenate"
|
||||||
op [a,b] = do
|
op [a,b] = do
|
||||||
ar <- whnf a
|
ar <- whnf a
|
||||||
@ -205,17 +347,101 @@ makeBuiltins whnf =
|
|||||||
(Term.Vector' a, Term.Vector' b) -> Term.vector' (a `mappend` b)
|
(Term.Vector' a, Term.Vector' b) -> Term.vector' (a `mappend` b)
|
||||||
(a,b) -> Term.ref r `Term.app` a `Term.app` b
|
(a,b) -> Term.ref r `Term.app` a `Term.app` b
|
||||||
op _ = fail "Vector.concatenate unpossible"
|
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"
|
, let r = R.Builtin "Vector.empty"
|
||||||
op [] = pure $ Term.vector mempty
|
op [] = pure $ Term.vector mempty
|
||||||
op _ = fail "Vector.empty unpossible"
|
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"
|
, let r = R.Builtin "Vector.fold-left"
|
||||||
op [f,z,vec] = whnf vec >>= \vec -> case vec of
|
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
|
Term.Vector' vs -> Vector.foldM (\acc a -> whnf (f `Term.apps` [acc, a])) z vs
|
||||||
_ -> pure $ Term.ref r `Term.app` vec
|
_ -> pure $ Term.ref r `Term.app` vec
|
||||||
op _ = fail "Vector.fold-left unpossible"
|
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"
|
, let r = R.Builtin "Vector.map"
|
||||||
op [f,vec] = do
|
op [f,vec] = do
|
||||||
vecr <- whnf vec
|
vecr <- whnf vec
|
||||||
@ -223,7 +449,7 @@ makeBuiltins whnf =
|
|||||||
Term.Vector' vs -> Term.vector' (fmap (Term.app f) vs)
|
Term.Vector' vs -> Term.vector' (fmap (Term.app f) vs)
|
||||||
_ -> Term.ref r `Term.app` vecr
|
_ -> Term.ref r `Term.app` vecr
|
||||||
op _ = fail "Vector.map unpossible"
|
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"
|
, let r = R.Builtin "Vector.prepend"
|
||||||
op [hd,tl] = do
|
op [hd,tl] = do
|
||||||
tlr <- whnf tl
|
tlr <- whnf tl
|
||||||
@ -231,13 +457,103 @@ makeBuiltins whnf =
|
|||||||
Term.Vector' tl -> Term.vector' (Vector.cons hd tl)
|
Term.Vector' tl -> Term.vector' (Vector.cons hd tl)
|
||||||
tl -> Term.ref r `Term.app` hd `Term.app` tl
|
tl -> Term.ref r `Term.app` hd `Term.app` tl
|
||||||
op _ = fail "Vector.prepend unpossible"
|
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"
|
, let r = R.Builtin "Vector.single"
|
||||||
op [hd] = pure $ Term.vector (pure hd)
|
op [hd] = pure $ Term.vector (pure hd)
|
||||||
op _ = fail "Vector.single unpossible"
|
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
|
-- type helpers
|
||||||
alignmentT :: Ord v => Type v
|
alignmentT :: Ord v => Type v
|
||||||
alignmentT = Type.ref (R.Builtin "Alignment")
|
alignmentT = Type.ref (R.Builtin "Alignment")
|
||||||
@ -245,6 +561,8 @@ numOpTyp :: Type V
|
|||||||
numOpTyp = unsafeParseType "Number -> Number -> Number"
|
numOpTyp = unsafeParseType "Number -> Number -> Number"
|
||||||
numCompareTyp :: Type V
|
numCompareTyp :: Type V
|
||||||
numCompareTyp = unsafeParseType "Number -> Number -> Boolean"
|
numCompareTyp = unsafeParseType "Number -> Number -> Boolean"
|
||||||
|
textCompareTyp :: Type V
|
||||||
|
textCompareTyp = unsafeParseType "Text -> Text -> Boolean"
|
||||||
strOpTyp :: Type V
|
strOpTyp :: Type V
|
||||||
strOpTyp = unsafeParseType "Text -> Text -> Text"
|
strOpTyp = unsafeParseType "Text -> Text -> Text"
|
||||||
unitT :: Ord v => Type v
|
unitT :: Ord v => Type v
|
||||||
|
@ -9,9 +9,10 @@ import Unison.Node.Store (Store)
|
|||||||
import Unison.Reference (Reference(Derived))
|
import Unison.Reference (Reference(Derived))
|
||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
|
import Unison.Util.Logger (Logger)
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import qualified Data.ByteString.Lazy as LB
|
|
||||||
import qualified Data.ByteString.Builder as Builder
|
import qualified Data.ByteString.Builder as Builder
|
||||||
|
import qualified Data.ByteString.Lazy as LB
|
||||||
import qualified Data.Digest.Murmur64 as Murmur
|
import qualified Data.Digest.Murmur64 as Murmur
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Text.Encoding as Encoding
|
import qualified Data.Text.Encoding as Encoding
|
||||||
@ -44,7 +45,7 @@ instance Hashable.Accumulate Hash where
|
|||||||
|
|
||||||
type V = Symbol.Symbol View.DFO
|
type V = Symbol.Symbol View.DFO
|
||||||
|
|
||||||
make :: IO (Node IO V Reference (Type V) (Term V))
|
make :: Logger -> IO (Node IO V Reference (Type V) (Term V))
|
||||||
make = do
|
make logger = do
|
||||||
store <- MemStore.make :: IO (Store IO V)
|
store <- MemStore.make :: IO (Store IO V)
|
||||||
BasicNode.make hash store Builtin.makeBuiltins
|
BasicNode.make hash store (Builtin.makeBuiltins logger)
|
||||||
|
@ -63,6 +63,18 @@ instance Applicative m => Applicative (Noted m) where
|
|||||||
pure = Noted . pure . pure
|
pure = Noted . pure . pure
|
||||||
(Noted f) <*> (Noted a) = Noted $ liftA2 (<*>) f a
|
(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 :: String -> Note
|
||||||
note s = Note [s]
|
note s = Note [s]
|
||||||
|
|
||||||
|
@ -1,3 +1,7 @@
|
|||||||
|
{-# Language DeriveFunctor #-}
|
||||||
|
{-# Language DeriveTraversable #-}
|
||||||
|
{-# Language DeriveFoldable #-}
|
||||||
|
|
||||||
module Unison.Parser where
|
module Unison.Parser where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
@ -8,54 +12,70 @@ import Data.Maybe
|
|||||||
import Prelude hiding (takeWhile)
|
import Prelude hiding (takeWhile)
|
||||||
import qualified Data.Char as Char
|
import qualified Data.Char as Char
|
||||||
import qualified Prelude
|
import qualified Prelude
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
newtype Parser a = Parser { run :: String -> Result a }
|
data Env s =
|
||||||
|
Env { overallInput :: String
|
||||||
|
, offset :: !Int
|
||||||
|
, state :: !s
|
||||||
|
, currentInput :: String } -- always just `drop offset overallInput`
|
||||||
|
|
||||||
root :: Parser a -> Parser a
|
newtype Parser s a = Parser { run' :: Env s -> Result s a }
|
||||||
root p = many (whitespace1 <|> haskellLineComment) *> (p <* eof)
|
|
||||||
|
|
||||||
eof :: Parser ()
|
root :: Parser s a -> Parser s a
|
||||||
eof = Parser $ \s -> case s of
|
root p = ignored *> (p <* (optional semicolon <* eof))
|
||||||
[] -> Succeed () 0 False
|
|
||||||
_ -> Fail [Prelude.takeWhile (/= '\n') s, "expected eof, got"] False
|
|
||||||
|
|
||||||
attempt :: Parser a -> Parser a
|
semicolon :: Parser s ()
|
||||||
attempt p = Parser $ \s -> case run p s of
|
semicolon = void $ token (char ';')
|
||||||
|
|
||||||
|
semicolon2 :: Parser s ()
|
||||||
|
semicolon2 = semicolon *> semicolon
|
||||||
|
|
||||||
|
eof :: Parser s ()
|
||||||
|
eof = Parser $ \env -> case (currentInput env) of
|
||||||
|
[] -> Succeed () (state env) 0
|
||||||
|
_ -> Fail [Prelude.takeWhile (/= '\n') (currentInput env), "expected eof"] False
|
||||||
|
|
||||||
|
attempt :: Parser s a -> Parser s a
|
||||||
|
attempt p = Parser $ \s -> case run' p s of
|
||||||
Fail stack _ -> Fail stack False
|
Fail stack _ -> Fail stack False
|
||||||
Succeed a n _ -> Succeed a n False
|
succeed -> succeed
|
||||||
|
|
||||||
unsafeRun :: Parser a -> String -> a
|
run :: Parser s a -> String -> s -> Result s a
|
||||||
unsafeRun p s = case toEither $ run p s of
|
run p s s0 = run' p (Env s 0 s0 s)
|
||||||
|
|
||||||
|
unsafeRun :: Parser s a -> String -> s -> a
|
||||||
|
unsafeRun p s s0 = case toEither $ run p s s0 of
|
||||||
Right a -> a
|
Right a -> a
|
||||||
Left e -> error ("Parse error:\n" ++ e)
|
Left e -> error ("Parse error:\n" ++ e)
|
||||||
|
|
||||||
unsafeGetSucceed :: Result a -> a
|
unsafeGetSucceed :: Result s a -> a
|
||||||
unsafeGetSucceed r = case r of
|
unsafeGetSucceed r = case r of
|
||||||
Succeed a _ _ -> a
|
Succeed a _ _ -> a
|
||||||
Fail e _ -> error (unlines ("Parse error:":e))
|
Fail e _ -> error (unlines ("Parse error:":e))
|
||||||
|
|
||||||
string :: String -> Parser String
|
string :: String -> Parser s String
|
||||||
string s = Parser $ \input ->
|
string s = Parser $ \env ->
|
||||||
if s `isPrefixOf` input then Succeed s (length s) False
|
if s `isPrefixOf` (currentInput env) then Succeed s (state env) (length s)
|
||||||
else Fail ["expected '" ++ s ++ "', got " ++ takeLine input] False
|
else Fail ["expected " ++ s ++ ", got " ++ takeLine (currentInput env)] False
|
||||||
|
|
||||||
takeLine :: String -> String
|
takeLine :: String -> String
|
||||||
takeLine = Prelude.takeWhile (/= '\n')
|
takeLine = Prelude.takeWhile (/= '\n')
|
||||||
|
|
||||||
char :: Char -> Parser Char
|
char :: Char -> Parser s Char
|
||||||
char c = Parser $ \input ->
|
char c = Parser $ \env ->
|
||||||
if listToMaybe input == Just c then Succeed c 1 False
|
if listToMaybe (currentInput env) == Just c then Succeed c (state env) 1
|
||||||
else Fail [] False
|
else Fail ["expected " ++ show c ++ ", got " ++ takeLine (currentInput env)] False
|
||||||
|
|
||||||
one :: (Char -> Bool) -> Parser Char
|
one :: (Char -> Bool) -> Parser s Char
|
||||||
one f = Parser $ \s -> case s of
|
one f = Parser $ \env -> case (currentInput env) of
|
||||||
(h:_) | f h -> Succeed h 1 False
|
(h:_) | f h -> Succeed h (state env) 1
|
||||||
_ -> Fail [] False
|
_ -> Fail [] False
|
||||||
|
|
||||||
base64string' :: String -> Parser String
|
base64string' :: String -> Parser s String
|
||||||
base64string' alphabet = concat <$> many base64group
|
base64string' alphabet = concat <$> many base64group
|
||||||
where
|
where
|
||||||
base64group :: Parser String
|
base64group :: Parser s String
|
||||||
base64group = do
|
base64group = do
|
||||||
chars <- some $ one (`elem` alphabet)
|
chars <- some $ one (`elem` alphabet)
|
||||||
padding <- sequenceA (replicate (padCount $ length chars) (char '='))
|
padding <- sequenceA (replicate (padCount $ length chars) (char '='))
|
||||||
@ -63,122 +83,148 @@ base64string' alphabet = concat <$> many base64group
|
|||||||
padCount :: Int -> Int
|
padCount :: Int -> Int
|
||||||
padCount len = case len `mod` 4 of 0 -> 0; n -> 4 - n
|
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'] ++ "-_"
|
base64urlstring = base64string' $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_"
|
||||||
|
|
||||||
notReservedChar :: Char -> Bool
|
notReservedChar :: Char -> Bool
|
||||||
notReservedChar = (`notElem` "\".,`[]{}:;()")
|
notReservedChar = (`notElem` "\".,`[]{}:;()")
|
||||||
|
|
||||||
identifier :: [String -> Bool] -> Parser String
|
identifier :: [String -> Bool] -> Parser s String
|
||||||
identifier = identifier' [not . isSpace, notReservedChar]
|
identifier = identifier' [not . isSpace, notReservedChar]
|
||||||
|
|
||||||
identifier' :: [Char -> Bool] -> [String -> Bool] -> Parser String
|
identifier' :: [Char -> Bool] -> [String -> Bool] -> Parser s String
|
||||||
identifier' charTests stringTests = do
|
identifier' charTests stringTests = do
|
||||||
i <- takeWhile1 "identifier" (\c -> all ($ c) charTests)
|
i <- takeWhile1 "identifier" (\c -> all ($ c) charTests)
|
||||||
guard (all ($ i) stringTests)
|
guard (all ($ i) stringTests)
|
||||||
pure i
|
pure i
|
||||||
|
|
||||||
token :: Parser a -> Parser a
|
-- a wordyId isn't all digits, isn't all symbols, and isn't a symbolyId
|
||||||
token p = p <* many (whitespace1 <|> haskellLineComment)
|
wordyId :: [String] -> Parser s String
|
||||||
|
wordyId keywords = do
|
||||||
|
op <- (False <$ symbolyId keywords) <|> pure True
|
||||||
|
guard op
|
||||||
|
token $ f <$> sepBy1 dot id
|
||||||
|
where
|
||||||
|
dot = char '.'
|
||||||
|
id = identifier [any (not . Char.isDigit), any Char.isAlphaNum, (`notElem` keywords)]
|
||||||
|
f segs = intercalate "." segs
|
||||||
|
|
||||||
haskellLineComment :: Parser ()
|
-- a symbolyId is all symbols
|
||||||
|
symbolyId :: [String] -> Parser s String
|
||||||
|
symbolyId keywords = scope "operator" . token $ do
|
||||||
|
op <- identifier'
|
||||||
|
[notReservedChar, (/= '_'), not . Char.isSpace, \c -> Char.isSymbol c || Char.isPunctuation c]
|
||||||
|
[(`notElem` keywords)]
|
||||||
|
qual <- optional (char '_' *> wordyId keywords)
|
||||||
|
pure $ maybe op (\qual -> qual ++ "." ++ op) qual
|
||||||
|
|
||||||
|
token :: Parser s a -> Parser s a
|
||||||
|
token p = p <* ignored
|
||||||
|
|
||||||
|
haskellLineComment :: Parser s ()
|
||||||
haskellLineComment = void $ string "--" *> takeWhile "-- comment" (/= '\n')
|
haskellLineComment = void $ string "--" *> takeWhile "-- comment" (/= '\n')
|
||||||
|
|
||||||
lineErrorUnless :: String -> Parser a -> Parser a
|
lineErrorUnless :: String -> Parser s a -> Parser s a
|
||||||
lineErrorUnless s p = commitFail $ Parser $ \input -> case run p input of
|
lineErrorUnless s = commit . scope s
|
||||||
Fail e b -> Fail (s:m:e) b
|
|
||||||
where m = "near \'" ++ Prelude.takeWhile (/= '\n') input ++ "\'"
|
|
||||||
ok -> ok
|
|
||||||
|
|
||||||
parenthesized :: Parser a -> Parser a
|
currentLine' :: Env s -> String
|
||||||
|
currentLine' (Env overall i s cur) = before ++ restOfLine where
|
||||||
|
-- this grabs the current line up to current offset, i
|
||||||
|
before = reverse . Prelude.takeWhile (/= '\n') . reverse . take i $ overall
|
||||||
|
restOfLine = Prelude.takeWhile (/= '\n') cur
|
||||||
|
|
||||||
|
currentLine :: Parser s String
|
||||||
|
currentLine = Parser $ \env -> Succeed (currentLine' env) (state env) 0
|
||||||
|
|
||||||
|
parenthesized :: Parser s a -> Parser s a
|
||||||
parenthesized p = lp *> body <* rp
|
parenthesized p = lp *> body <* rp
|
||||||
where
|
where
|
||||||
lp = token (char '(')
|
lp = token (char '(')
|
||||||
body = p
|
body = p
|
||||||
rp = lineErrorUnless "missing )" $ token (char ')')
|
rp = lineErrorUnless "missing )" $ token (char ')')
|
||||||
|
|
||||||
takeWhile :: String -> (Char -> Bool) -> Parser String
|
takeWhile :: String -> (Char -> Bool) -> Parser s String
|
||||||
takeWhile msg f = scope msg . Parser $ \s ->
|
takeWhile msg f = scope msg . Parser $ \(Env _ _ s cur) ->
|
||||||
let hd = Prelude.takeWhile f s
|
let hd = Prelude.takeWhile f cur
|
||||||
in Succeed hd (length hd) False
|
in Succeed hd s (length hd)
|
||||||
|
|
||||||
takeWhile1 :: String -> (Char -> Bool) -> Parser String
|
takeWhile1 :: String -> (Char -> Bool) -> Parser s String
|
||||||
takeWhile1 msg f = scope msg . Parser $ \s ->
|
takeWhile1 msg f = scope msg . Parser $ \(Env _ _ s cur) ->
|
||||||
let hd = Prelude.takeWhile f s
|
let hd = Prelude.takeWhile f cur
|
||||||
in if null hd then Fail ["takeWhile1 empty: " ++ take 20 s] False
|
in if null hd then Fail [] False
|
||||||
else Succeed hd (length hd) False
|
else Succeed hd s (length hd)
|
||||||
|
|
||||||
whitespace :: Parser ()
|
whitespace :: Parser s ()
|
||||||
whitespace = void $ takeWhile "whitespace" Char.isSpace
|
whitespace = void $ takeWhile "whitespace" Char.isSpace
|
||||||
|
|
||||||
whitespace1 :: Parser ()
|
whitespace1 :: Parser s ()
|
||||||
whitespace1 = void $ takeWhile1 "whitespace1" Char.isSpace
|
whitespace1 = void $ takeWhile1 "whitespace1" Char.isSpace
|
||||||
|
|
||||||
nonempty :: Parser a -> Parser a
|
nonempty :: Parser s a -> Parser s a
|
||||||
nonempty p = Parser $ \s -> case run p s of
|
nonempty p = Parser $ \s -> case run' p s of
|
||||||
Succeed _ 0 b -> Fail [] b
|
Succeed _ _ 0 -> Fail [] False
|
||||||
ok -> ok
|
ok -> ok
|
||||||
|
|
||||||
scope :: String -> Parser a -> Parser a
|
scope :: String -> Parser s a -> Parser s a
|
||||||
scope s p = Parser $ \input -> case run p input of
|
scope s p = Parser $ \env -> case run' p env of
|
||||||
Fail e b -> Fail (s:e) b
|
Fail e b -> Fail (currentLine' env : s:e) b
|
||||||
ok -> ok
|
ok -> ok
|
||||||
|
|
||||||
commitSuccess :: Parser a -> Parser a
|
commit :: Parser s a -> Parser s a
|
||||||
commitSuccess p = Parser $ \input -> case run p input of
|
commit p = Parser $ \input -> case run' p input of
|
||||||
Fail e b -> Fail e b
|
|
||||||
Succeed a n _ -> Succeed a n True
|
|
||||||
|
|
||||||
commitFail :: Parser a -> Parser a
|
|
||||||
commitFail p = Parser $ \input -> case run p input of
|
|
||||||
Fail e _ -> Fail e True
|
Fail e _ -> Fail e True
|
||||||
Succeed a n b -> Succeed a n b
|
Succeed a s n -> Succeed a s n
|
||||||
|
|
||||||
commit' :: Parser ()
|
sepBy :: Parser s a -> Parser s b -> Parser s [b]
|
||||||
commit' = commitSuccess (pure ())
|
|
||||||
|
|
||||||
failWith :: String -> Parser a
|
|
||||||
failWith error = Parser . const $ Fail [error] False
|
|
||||||
|
|
||||||
sepBy :: Parser a -> Parser b -> Parser [b]
|
|
||||||
sepBy sep pb = f <$> optional (sepBy1 sep pb)
|
sepBy sep pb = f <$> optional (sepBy1 sep pb)
|
||||||
where
|
where
|
||||||
f Nothing = []
|
f Nothing = []
|
||||||
f (Just l) = l
|
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)
|
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 (Fail e _) = Left (intercalate "\n" e)
|
||||||
toEither (Succeed a _ _) = Right a
|
toEither (Succeed a _ _) = Right a
|
||||||
|
|
||||||
data Result a
|
data Result s a
|
||||||
= Fail [String] Bool
|
= Fail [String] !Bool
|
||||||
| Succeed a Int Bool
|
| Succeed a s !Int
|
||||||
deriving (Show)
|
deriving (Show,Functor,Foldable,Traversable)
|
||||||
|
|
||||||
instance Functor Parser where
|
get :: Parser s s
|
||||||
|
get = Parser (\env -> Succeed (state env) (state env) 0)
|
||||||
|
|
||||||
|
set :: s -> Parser s ()
|
||||||
|
set s = Parser (\env -> Succeed () s 0)
|
||||||
|
|
||||||
|
instance Functor (Parser s) where
|
||||||
fmap = liftM
|
fmap = liftM
|
||||||
|
|
||||||
instance Applicative Parser where
|
instance Applicative (Parser s) where
|
||||||
pure = return
|
pure = return
|
||||||
(<*>) = ap
|
(<*>) = ap
|
||||||
|
|
||||||
instance Alternative Parser where
|
instance Alternative (Parser s) where
|
||||||
empty = mzero
|
empty = mzero
|
||||||
(<|>) = mplus
|
(<|>) = mplus
|
||||||
|
|
||||||
instance Monad Parser where
|
instance Monad (Parser s) where
|
||||||
return a = Parser $ \_ -> Succeed a 0 False
|
return a = Parser $ \env -> Succeed a (state env) 0
|
||||||
Parser p >>= f = Parser $ \s -> case p s of
|
Parser p >>= f = Parser $ \env@(Env overall i s cur) -> case p env of
|
||||||
Succeed a n committed -> case run (f a) (drop n s) of
|
Succeed a s n ->
|
||||||
Succeed b m c2 -> Succeed b (n+m) (committed || c2)
|
case run' (f a) (Env overall (i+n) s (drop n cur)) of
|
||||||
Fail e b -> Fail e (committed || b)
|
Succeed b s m -> Succeed b s (n+m)
|
||||||
Fail e b -> Fail e b
|
Fail e b -> Fail e b
|
||||||
|
Fail 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
|
mzero = Parser $ \_ -> Fail [] False
|
||||||
mplus p1 p2 = Parser $ \s -> case run p1 s of
|
mplus p1 p2 = Parser $ \env -> case run' p1 env of
|
||||||
Fail _ False -> run p2 s
|
Fail _ False -> run' p2 env
|
||||||
ok -> ok
|
ok -> ok
|
||||||
|
@ -8,6 +8,7 @@ import Unison.Symbol (Symbol)
|
|||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Parser (Result(..), run, unsafeGetSucceed)
|
import Unison.Parser (Result(..), run, unsafeGetSucceed)
|
||||||
|
import Unison.Var (Var)
|
||||||
import Unison.View (DFO)
|
import Unison.View (DFO)
|
||||||
import qualified Unison.Parser as Parser
|
import qualified Unison.Parser as Parser
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
@ -20,36 +21,28 @@ import qualified Unison.Reference as R
|
|||||||
import qualified Unison.Var as Var
|
import qualified Unison.Var as Var
|
||||||
|
|
||||||
type V = Symbol DFO
|
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
|
parseTerm = parseTerm' termBuiltins typeBuiltins
|
||||||
|
|
||||||
parseType :: String -> Result (Type V)
|
parseType :: String -> Result S (Type V)
|
||||||
parseType = parseType' typeBuiltins
|
parseType = parseType' typeBuiltins
|
||||||
|
|
||||||
parseTerm' :: [(V, Term V)] -> [(V, Type V)] -> String -> Result (Term V)
|
parseTerm' :: [(V, Term V)] -> [(V, Type V)] -> String -> Result S (Term V)
|
||||||
parseTerm' termBuiltins typeBuiltins s = case run (Parser.root TermParser.term) s of
|
parseTerm' termBuiltins typeBuiltins s =
|
||||||
Succeed e n b ->
|
bindBuiltins termBuiltins typeBuiltins <$> run (Parser.root TermParser.term) s s0
|
||||||
Succeed (Term.typeMap (ABT.substs typeBuiltins) (ABT.substs termBuiltins e)) n b
|
|
||||||
fail -> fail
|
|
||||||
|
|
||||||
parseType' :: [(V, Type V)] -> String -> Result (Type V)
|
bindBuiltins :: Var v => [(v, Term v)] -> [(v, Type v)] -> Term v -> Term v
|
||||||
parseType' typeBuiltins s = case run (Parser.root TypeParser.type_) s of
|
bindBuiltins termBuiltins typeBuiltins =
|
||||||
Succeed t n b -> Succeed (ABT.substs typeBuiltins t) n b
|
Term.typeMap (ABT.substs typeBuiltins) . ABT.substs termBuiltins
|
||||||
fail -> fail
|
|
||||||
|
|
||||||
prelude = unlines
|
parseType' :: [(V, Type V)] -> String -> Result S (Type V)
|
||||||
[ "let"
|
parseType' typeBuiltins s =
|
||||||
, " Index.empty : forall k v . Remote (Index k v);"
|
ABT.substs typeBuiltins <$> run (Parser.root TypeParser.type_) s s0
|
||||||
, " Index.empty = Remote.map Index.unsafeEmpty Remote.here;"
|
|
||||||
, ""
|
|
||||||
, " Remote.transfer : Node -> Remote Unit;"
|
|
||||||
, " Remote.transfer node = Remote.at node unit"
|
|
||||||
, "in"
|
|
||||||
, ""]
|
|
||||||
|
|
||||||
unsafeParseTermWithPrelude :: String -> Term V
|
|
||||||
unsafeParseTermWithPrelude prog = unsafeParseTerm (prelude ++ prog)
|
|
||||||
|
|
||||||
unsafeParseTerm :: String -> Term V
|
unsafeParseTerm :: String -> Term V
|
||||||
unsafeParseTerm = unsafeGetSucceed . parseTerm
|
unsafeParseTerm = unsafeGetSucceed . parseTerm
|
||||||
@ -74,35 +67,26 @@ data Builtin = Builtin Text -- e.g. Builtin "()"
|
|||||||
| AliasFromModule Text [Text] [Text]
|
| AliasFromModule Text [Text] [Text]
|
||||||
|
|
||||||
-- aka default imports
|
-- aka default imports
|
||||||
termBuiltins :: [(V, Term V)]
|
termBuiltins :: Var v => [(v, Term v)]
|
||||||
termBuiltins = (Var.named *** Term.ref) <$> (
|
termBuiltins = (Var.named *** Term.ref) <$> (
|
||||||
[ Alias "+" "Number.plus"
|
[ Builtin "True"
|
||||||
, Alias "-" "Number.minus"
|
|
||||||
, Alias "*" "Number.times"
|
|
||||||
, Alias "/" "Number.divide"
|
|
||||||
, Alias ">" "Number.greaterThan"
|
|
||||||
, Alias "<" "Number.lessThan"
|
|
||||||
, Alias ">=" "Number.greaterThanOrEqual"
|
|
||||||
, Alias "<=" "Number.lessThanOrEqual"
|
|
||||||
, Alias "==" "Number.equal"
|
|
||||||
, Alias "if" "Boolean.if"
|
|
||||||
, Builtin "True"
|
|
||||||
, Builtin "False"
|
, Builtin "False"
|
||||||
, Builtin "()"
|
, Builtin "()"
|
||||||
|
, Builtin "Either.Right"
|
||||||
|
, Builtin "Either.Left"
|
||||||
|
, Builtin "Greater"
|
||||||
|
, Builtin "Less"
|
||||||
|
, Builtin "Equal"
|
||||||
, Alias "unit" "()"
|
, Alias "unit" "()"
|
||||||
, Alias "some" "Optional.Some"
|
, Alias "Unit" "()"
|
||||||
, Alias "none" "Optional.None"
|
, Alias "Some" "Optional.Some"
|
||||||
, AliasFromModule "Vector"
|
, Alias "None" "Optional.None"
|
||||||
["single", "prepend", "map", "fold-left", "concatenate", "append"] ["empty"]
|
, Alias "+" "Number.+"
|
||||||
, AliasFromModule "Text"
|
, Alias "-" "Number.-"
|
||||||
["concatenate", "left", "right", "center", "justify"] []
|
, Alias "*" "Number.*"
|
||||||
, AliasFromModule "Remote"
|
, Alias "/" "Number./"
|
||||||
["fork", "receive", "receiveAsync", "pure", "bind", "map", "channel", "send", "here", "at", "spawn"] []
|
, AliasFromModule "Vector" ["single"] []
|
||||||
, AliasFromModule "Color" ["rgba"] []
|
, AliasFromModule "Remote" ["pure", "bind", "pure", "fork"] []
|
||||||
, AliasFromModule "Symbol" ["Symbol"] []
|
|
||||||
, AliasFromModule "Index" ["lookup", "unsafeLookup", "insert", "unsafeInsert", "empty", "unsafeEmpty"] []
|
|
||||||
, AliasFromModule "Html" ["getLinks", "getHref", "getDescription"] []
|
|
||||||
, AliasFromModule "Http" ["getURL", "unsafeGetURL"] []
|
|
||||||
] >>= unpackAliases)
|
] >>= unpackAliases)
|
||||||
where
|
where
|
||||||
unpackAliases :: Builtin -> [(Text, R.Reference)]
|
unpackAliases :: Builtin -> [(Text, R.Reference)]
|
||||||
@ -117,26 +101,27 @@ termBuiltins = (Var.named *** Term.ref) <$> (
|
|||||||
aliasFromModule m sym = alias sym (Text.intercalate "." [m, sym])
|
aliasFromModule m sym = alias sym (Text.intercalate "." [m, sym])
|
||||||
builtinInModule m sym = builtin (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) <$>
|
typeBuiltins = (Var.named *** Type.lit) <$>
|
||||||
[ ("Number", Type.Number)
|
[ ("Number", Type.Number)
|
||||||
, builtin "Unit"
|
, builtin "Unit"
|
||||||
, builtin "Boolean"
|
, builtin "Boolean"
|
||||||
, ("Optional", Type.Optional)
|
, ("Optional", Type.Optional)
|
||||||
, builtin "Either"
|
, builtin "Either"
|
||||||
-- ???
|
, builtin "Pair"
|
||||||
, builtin "Symbol"
|
, builtin "Order"
|
||||||
, builtin "Alignment"
|
, builtin "Comparison"
|
||||||
, builtin "Color"
|
, builtin "Order.Key"
|
||||||
, builtin "Fixity"
|
|
||||||
-- kv store
|
-- kv store
|
||||||
, builtin "Index"
|
, builtin "Index"
|
||||||
-- html
|
-- html
|
||||||
, builtin "Link"
|
, builtin "Html.Link"
|
||||||
-- distributed
|
-- distributed
|
||||||
, builtin "Channel"
|
, builtin "Channel"
|
||||||
, builtin "Future"
|
, builtin "Duration"
|
||||||
, builtin "Remote"
|
, builtin "Remote"
|
||||||
, builtin "Node"
|
, builtin "Node"
|
||||||
|
-- hashing
|
||||||
|
, builtin "Hash"
|
||||||
]
|
]
|
||||||
where builtin t = (t, Type.Ref $ R.Builtin t)
|
where builtin t = (t, Type.Ref $ R.Builtin t)
|
||||||
|
@ -100,8 +100,10 @@ data Local t
|
|||||||
| CreateChannel
|
| CreateChannel
|
||||||
-- here : Local Node
|
-- here : Local Node
|
||||||
| Here
|
| Here
|
||||||
-- receiveAsync : Channel a -> Local (Local a)
|
-- sleep : Duration -> Local ()
|
||||||
| ReceiveAsync Channel Timeout
|
| Sleep Duration
|
||||||
|
-- receiveAsync : Channel a -> Duration -> Local (Local a)
|
||||||
|
| ReceiveAsync Channel Duration
|
||||||
-- receive : Channel a -> Local a
|
-- receive : Channel a -> Local a
|
||||||
| Receive Channel
|
| Receive Channel
|
||||||
-- send : Channel a -> a -> Local ()
|
-- send : Channel a -> a -> Local ()
|
||||||
@ -121,16 +123,17 @@ instance Hashable1 Local where
|
|||||||
Receive c -> [tag 4, H.accumulateToken c]
|
Receive c -> [tag 4, H.accumulateToken c]
|
||||||
Send c t -> [tag 5, H.accumulateToken c, hashed t]
|
Send c t -> [tag 5, H.accumulateToken c, hashed t]
|
||||||
Spawn -> [tag 6]
|
Spawn -> [tag 6]
|
||||||
Pure t -> [tag 7, hashed t]
|
Sleep (Seconds d) -> [tag 7, H.Double d]
|
||||||
|
Pure t -> [tag 8, hashed t]
|
||||||
where
|
where
|
||||||
tag = H.Tag
|
tag = H.Tag
|
||||||
hashed1 = H.Hashed . (H.hash1 hashCycle hash)
|
hashed1 = H.Hashed . (H.hash1 hashCycle hash)
|
||||||
hashed = H.Hashed . hash
|
hashed = H.Hashed . hash
|
||||||
|
|
||||||
newtype Timeout = Seconds { seconds :: Double } deriving (Eq,Ord,Show,Generic)
|
newtype Duration = Seconds { seconds :: Double } deriving (Eq,Ord,Show,Generic)
|
||||||
instance ToJSON Timeout
|
instance ToJSON Duration
|
||||||
instance FromJSON Timeout
|
instance FromJSON Duration
|
||||||
instance Hashable Timeout where
|
instance Hashable Duration where
|
||||||
tokens (Seconds seconds) = [H.Double seconds]
|
tokens (Seconds seconds) = [H.Double seconds]
|
||||||
|
|
||||||
|
|
||||||
@ -168,7 +171,10 @@ instance Hashable Node where
|
|||||||
instance Show Node where
|
instance Show Node where
|
||||||
show (Node host key) = "http://" ++ Text.unpack host ++ "/" ++ Text.unpack (decodeUtf8 (Base64.encode key))
|
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 ToJSON Channel where toJSON (Channel c) = toJSON (decodeUtf8 (Base64.encode c))
|
||||||
|
|
||||||
instance FromJSON Channel where
|
instance FromJSON Channel where
|
||||||
|
@ -45,11 +45,13 @@ import qualified Unison.Remote as Remote
|
|||||||
data Literal
|
data Literal
|
||||||
= Number Double
|
= Number Double
|
||||||
| Text Text
|
| Text Text
|
||||||
|
| If
|
||||||
deriving (Eq,Ord,Generic)
|
deriving (Eq,Ord,Generic)
|
||||||
|
|
||||||
instance Hashable Literal where
|
instance Hashable Literal where
|
||||||
tokens (Number d) = [Hashable.Tag 0, Hashable.Double d]
|
tokens (Number d) = [Hashable.Tag 0, Hashable.Double d]
|
||||||
tokens (Text txt) = [Hashable.Tag 1, Hashable.Text txt]
|
tokens (Text txt) = [Hashable.Tag 1, Hashable.Text txt]
|
||||||
|
tokens If = [Hashable.Tag 2]
|
||||||
|
|
||||||
-- | Base functor for terms in the Unison language
|
-- | Base functor for terms in the Unison language
|
||||||
data F v a
|
data F v a
|
||||||
@ -119,6 +121,7 @@ pattern Var' v <- ABT.Var' v
|
|||||||
pattern Lit' l <- (ABT.out -> ABT.Tm (Lit l))
|
pattern Lit' l <- (ABT.out -> ABT.Tm (Lit l))
|
||||||
pattern Number' n <- Lit' (Number n)
|
pattern Number' n <- Lit' (Number n)
|
||||||
pattern Text' s <- Lit' (Text s)
|
pattern Text' s <- Lit' (Text s)
|
||||||
|
pattern If' <- Lit' If
|
||||||
pattern Blank' <- (ABT.out -> ABT.Tm Blank)
|
pattern Blank' <- (ABT.out -> ABT.Tm Blank)
|
||||||
pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r))
|
pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r))
|
||||||
pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin 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 _ [] = []
|
||||||
go fn args = fn:args
|
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' :: Ord v => Term v -> Set Reference
|
||||||
dependencies' t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
dependencies' t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||||
where f t@(Ref r) = Writer.tell [r] *> pure 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
|
where f Blank = Writer.tell (Monoid.Sum (1 :: Int)) *> pure Blank
|
||||||
f t = pure t
|
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,
|
-- | If the outermost term is a function application,
|
||||||
-- perform substitution of the argument into the body
|
-- perform substitution of the argument into the body
|
||||||
betaReduce :: Var v => Term v -> Term v
|
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
|
instance Show Literal where
|
||||||
show (Text t) = show t
|
show (Text t) = show t
|
||||||
|
show If = "if"
|
||||||
show (Number n) = case floor n of
|
show (Number n) = case floor n of
|
||||||
m | fromIntegral m == n -> show (m :: Int)
|
m | fromIntegral m == n -> show (m :: Int)
|
||||||
_ -> show n
|
_ -> show n
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
{-# Language OverloadedStrings #-}
|
{-# Language OverloadedStrings #-}
|
||||||
|
{-# Language ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Unison.TermParser where
|
module Unison.TermParser where
|
||||||
|
|
||||||
@ -7,7 +8,7 @@ import Prelude hiding (takeWhile)
|
|||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.Char (isDigit, isAlphaNum, isSpace, isSymbol, isPunctuation)
|
import Data.Char (isDigit, isAlphaNum, isSpace, isSymbol, isPunctuation)
|
||||||
import Data.Foldable (asum)
|
import Data.Foldable (asum)
|
||||||
import Data.Functor (($>), void)
|
import Data.Functor
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Unison.Parser
|
import Unison.Parser
|
||||||
@ -18,6 +19,7 @@ import qualified Data.Set as Set
|
|||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Unison.ABT as ABT
|
import qualified Unison.ABT as ABT
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
|
import qualified Unison.Type as Type
|
||||||
import qualified Unison.TypeParser as TypeParser
|
import qualified Unison.TypeParser as TypeParser
|
||||||
import qualified Unison.Var as Var
|
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.
|
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
|
term = possiblyAnnotated term2
|
||||||
|
|
||||||
term2 :: (Var v, Show v) => Parser (Term v)
|
term2 :: Var v => Parser (S v) (Term v)
|
||||||
term2 = let_ term3 <|> term3
|
term2 = let_ term3 <|> term3
|
||||||
|
|
||||||
term3 ::(Var v, Show v) => Parser (Term v)
|
term3 :: Var v => Parser (S v) (Term v)
|
||||||
term3 = infixApp term4 <|> term4
|
term3 = ifthen <|> infixApp term4 <|> term4
|
||||||
|
|
||||||
infixApp :: Var v => Parser (Term v) -> Parser (Term v)
|
infixApp :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
|
||||||
infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
|
infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
|
||||||
where
|
where
|
||||||
arg = p
|
arg = p
|
||||||
@ -49,52 +53,81 @@ infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
|
|||||||
g :: Ord v => Term v -> (v, Term v) -> Term v
|
g :: Ord v => Term v -> (v, Term v) -> Term v
|
||||||
g lhs (op, rhs) = Term.apps (Term.var op) [lhs,rhs]
|
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
|
term4 = prefixApp term5
|
||||||
|
|
||||||
term5 :: (Var v, Show v) => Parser (Term v)
|
term5 :: Var v => Parser (S v) (Term v)
|
||||||
term5 = lam term <|> effectBlock <|> termLeaf
|
term5 = lam term <|> effectBlock <|> termLeaf
|
||||||
|
|
||||||
termLeaf :: (Var v, Show v) => Parser (Term v)
|
termLeaf :: Var v => Parser (S v) (Term v)
|
||||||
termLeaf = asum [hashLit, prefixTerm, lit, parenthesized term, blank, vector term]
|
termLeaf = asum [hashLit, prefixTerm, lit, tupleOrParenthesized term, blank, vector term]
|
||||||
|
|
||||||
|
ifthen :: Var v => Parser (S v) (Term v)
|
||||||
|
ifthen = do
|
||||||
|
_ <- token (string "if")
|
||||||
|
scope "if-then-else" . commit $ do
|
||||||
|
cond <- attempt term
|
||||||
|
_ <- token (string "then")
|
||||||
|
iftrue <- attempt term
|
||||||
|
_ <- token (string "else")
|
||||||
|
iffalse <- term
|
||||||
|
pure (Term.apps (Term.lit Term.If) [cond, iftrue, iffalse])
|
||||||
|
|
||||||
|
tupleOrParenthesized :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
|
||||||
|
tupleOrParenthesized rec =
|
||||||
|
parenthesized $ go <$> sepBy1 (token $ string ",") rec where
|
||||||
|
go [t] = t -- was just a parenthesized term
|
||||||
|
go terms = foldr pair unit terms -- it's a tuple literal
|
||||||
|
pair t1 t2 = Term.builtin "Pair" `Term.app` t1 `Term.app` t2
|
||||||
|
unit = Term.builtin "()"
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Remote { x := pure 23; y := at node2 23; pure 19 }
|
-- do Remote x := pure 23; y := at node2 23; pure 19;;
|
||||||
-- Remote { action1; action2; }
|
-- do Remote action1; action2;;
|
||||||
-- Remote { action1; x = 1 + 1; action2; }
|
-- do Remote action1; x = 1 + 1; action2;;
|
||||||
effectBlock :: (Var v, Show v) => Parser (Term v)
|
-- do Remote
|
||||||
effectBlock = do
|
-- x := pure 23;
|
||||||
name <- wordyId <* token (string "{")
|
-- y = 11;
|
||||||
let qualifiedPure = ABT.var' (Text.pack name `mappend` Text.pack ".pure")
|
-- pure (f x);;
|
||||||
qualifiedBind = ABT.var' (Text.pack name `mappend` Text.pack ".bind")
|
effectBlock :: forall v . Var v => Parser (S v) (Term v)
|
||||||
bindings <- some $ asum [Right <$> binding qualifiedPure, Left <$> action qualifiedPure]
|
effectBlock = (token (string "do") *> wordyId keywords) >>= go where
|
||||||
Just result <- pure $ foldr (bind qualifiedBind) Nothing bindings
|
go name = do
|
||||||
result <$ lineErrorUnless "missing }" (token (string "}"))
|
bindings <- some $ asum [Right <$> binding, Left <$> action] <* semicolon
|
||||||
|
semicolon
|
||||||
|
Just result <- pure $ foldr bind Nothing bindings
|
||||||
|
pure result
|
||||||
where
|
where
|
||||||
bind qb = go where
|
qualifiedPure, qualifiedBind :: Term v
|
||||||
go (Right (lhs,rhs)) (Just acc) = Just $ qb `Term.apps` [Term.lam lhs acc, rhs]
|
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 (Right (_,_)) Nothing = Nothing
|
||||||
go (Left action) (Just acc) = Just $ qb `Term.apps` [Term.lam (ABT.v' "_") acc, action]
|
go (Left action) (Just acc) = Just $ qualifiedBind `Term.apps` [Term.lam (ABT.v' "_") acc, action]
|
||||||
go (Left action) _ = Just action
|
go (Left action) _ = Just action
|
||||||
interpretPure qp = ABT.subst (ABT.v' "pure") qp
|
interpretPure :: Term v -> Term v
|
||||||
binding qp = scope "binding" $ do
|
interpretPure = ABT.subst (ABT.v' "pure") qualifiedPure
|
||||||
lhs <- ABT.v' . Text.pack <$> token wordyId
|
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 "=")
|
eff <- token $ (True <$ string ":=") <|> (False <$ string "=")
|
||||||
rhs <- term <* token (string ";")
|
rhs <- commit term
|
||||||
let rhs' = if eff then interpretPure qp rhs
|
let rhs' = if eff then interpretPure rhs
|
||||||
else qp `Term.app` rhs
|
else qualifiedPure `Term.app` rhs
|
||||||
pure (lhs, rhs')
|
pure (lhs, rhs')
|
||||||
action qp = attempt . scope "action" $ (interpretPure qp <$> term) <* token (string ";")
|
action :: Parser (S v) (Term v)
|
||||||
|
action = scope "action" $ (interpretPure <$> term)
|
||||||
|
|
||||||
text' :: Parser Literal
|
text' :: Parser s Literal
|
||||||
text' =
|
text' =
|
||||||
token $ fmap (Term.Text . Text.pack) ps
|
token $ fmap (Term.Text . Text.pack) ps
|
||||||
where ps = char '"' *> Unison.Parser.takeWhile "text literal" (/= '"') <* char '"'
|
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'
|
text = Term.lit <$> text'
|
||||||
|
|
||||||
number' :: Parser Literal
|
number' :: Parser s Literal
|
||||||
number' = token (f <$> digits <*> optional ((:) <$> char '.' <*> digits))
|
number' = token (f <$> digits <*> optional ((:) <$> char '.' <*> digits))
|
||||||
where
|
where
|
||||||
digits = nonempty (takeWhile "number" isDigit)
|
digits = nonempty (takeWhile "number" isDigit)
|
||||||
@ -102,26 +135,26 @@ number' = token (f <$> digits <*> optional ((:) <$> char '.' <*> digits))
|
|||||||
f whole part =
|
f whole part =
|
||||||
(Term.Number . read) $ maybe whole (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))
|
hashLit = token (f <$> (mark *> hash))
|
||||||
where
|
where
|
||||||
f = Term.derived' . Text.pack
|
f = Term.derived' . Text.pack
|
||||||
mark = char '#'
|
mark = char '#'
|
||||||
hash = lineErrorUnless "error parsing base64url hash" base64urlstring
|
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'
|
number = Term.lit <$> number'
|
||||||
|
|
||||||
lit' :: Parser Literal
|
lit' :: Parser s Literal
|
||||||
lit' = text' <|> number'
|
lit' = text' <|> number'
|
||||||
|
|
||||||
lit :: Ord v => Parser (Term v)
|
lit :: Ord v => Parser (S v) (Term v)
|
||||||
lit = Term.lit <$> lit'
|
lit = Term.lit <$> lit'
|
||||||
|
|
||||||
blank :: Ord v => Parser (Term v)
|
blank :: Ord v => Parser (S v) (Term v)
|
||||||
blank = token (char '_') $> Term.blank
|
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)
|
vector p = Term.vector <$> (lbracket *> elements <* rbracket)
|
||||||
where
|
where
|
||||||
lbracket = token (char '[')
|
lbracket = token (char '[')
|
||||||
@ -129,109 +162,100 @@ vector p = Term.vector <$> (lbracket *> elements <* rbracket)
|
|||||||
comma = token (char ',')
|
comma = token (char ',')
|
||||||
rbracket = lineErrorUnless "syntax error" $ 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''
|
possiblyAnnotated p = f <$> p <*> optional ann''
|
||||||
where
|
where
|
||||||
f t (Just y) = Term.ann t y
|
f t (Just y) = Term.ann t y
|
||||||
f t Nothing = t
|
f t Nothing = t
|
||||||
|
|
||||||
ann'' :: Var v => Parser (Type v)
|
ann'' :: Var v => Parser (S v) (Type v)
|
||||||
ann'' = token (char ':') *> TypeParser.type_
|
ann'' = token (char ':') *> TypeParser.type_
|
||||||
|
|
||||||
--let server = _; blah = _ in _
|
--let server = _; blah = _ in _
|
||||||
let_ :: (Var v, Show v) => Parser (Term v) -> Parser (Term v)
|
let_ :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
|
||||||
let_ p = f <$> (let_ *> optional rec_) <*> bindings' <* in_ <*> body
|
let_ p = f <$> (let_ *> optional rec_) <*> bindings'
|
||||||
where
|
where
|
||||||
let_ = token (string "let")
|
let_ = token (string "let")
|
||||||
rec_ = token (string "rec") $> ()
|
rec_ = token (string "rec") $> ()
|
||||||
bindings' = lineErrorUnless "error parsing let bindings" (bindings p)
|
bindings' = do
|
||||||
in_ = lineErrorUnless "missing 'in' after bindings in let-expression'" $ token (string "in")
|
bs <- lineErrorUnless "error parsing let bindings" (bindings p)
|
||||||
body = lineErrorUnless "parse error in body of let-expression" p
|
body <- lineErrorUnless "parse error in body of let-expression" term
|
||||||
-- f = maybe Term.let1'
|
semicolon2
|
||||||
f :: Ord v => Maybe () -> [(v, Term v)] -> Term v -> Term v
|
pure (bs, body)
|
||||||
f Nothing bindings body = Term.let1 bindings body
|
f :: Ord v => Maybe () -> ([(v, Term v)], Term v) -> Term v
|
||||||
f (Just _) bindings body = Term.letRec bindings body
|
f Nothing (bindings, body) = Term.let1 bindings body
|
||||||
|
f (Just _) (bindings, body) = Term.letRec bindings body
|
||||||
|
|
||||||
|
typedecl :: Var v => Parser (S v) (v, Type v)
|
||||||
semicolon :: Parser ()
|
|
||||||
semicolon = void $ token (char ';')
|
|
||||||
|
|
||||||
infixBinding :: (Var v, Show v) => Parser (Term v) -> Parser (v, Term v)
|
|
||||||
infixBinding p = ((,,,,) <$> optional (typedecl <* semicolon) <*> prefixVar <*> infixVar <*> prefixVar <*> bindingEqBody p) >>= f
|
|
||||||
where
|
|
||||||
f :: (Ord v, Show v) => (Maybe (v, Type v), v, v, v, Term v) -> Parser (v, Term v)
|
|
||||||
f (Just (opName', _), _, opName, _, _) | opName /= opName' =
|
|
||||||
failWith ("The type signature for ‘" ++ show opName' ++ "’ lacks an accompanying binding")
|
|
||||||
f (Nothing, arg1, opName, arg2, body) = pure (mkBinding opName [arg1,arg2] body)
|
|
||||||
f (Just (_, type'), arg1, opName, arg2, body) = pure $ (`Term.ann` type') <$> mkBinding opName [arg1,arg2] body
|
|
||||||
|
|
||||||
mkBinding :: Ord v => v -> [v] -> Term v -> (v, Term v)
|
|
||||||
mkBinding f [] body = (f, body)
|
|
||||||
mkBinding f args body = (f, Term.lam'' args body)
|
|
||||||
|
|
||||||
typedecl :: Var v => Parser (v, Type v)
|
|
||||||
typedecl = (,) <$> prefixVar <*> ann''
|
typedecl = (,) <$> prefixVar <*> ann''
|
||||||
|
|
||||||
prefixBinding :: (Var v, Show v) => Parser (Term v) -> Parser (v, Term v)
|
bindingEqBody :: Parser (S v) (Term v) -> Parser (S v) (Term v)
|
||||||
prefixBinding p = ((,,,) <$> optional (typedecl <* semicolon) <*> prefixVar <*> many prefixVar <*> bindingEqBody p) >>= f -- todo
|
|
||||||
where
|
|
||||||
f :: (Ord v, Show v) => (Maybe (v, Type v), v, [v], Term v) -> Parser (v, Term v)
|
|
||||||
f (Just (opName, _), opName', _, _) | opName /= opName' =
|
|
||||||
failWith ("The type signature for ‘" ++ show opName' ++ "’ lacks an accompanying binding")
|
|
||||||
f (Nothing, name, args, body) = pure $ mkBinding name args body
|
|
||||||
f (Just (_, t), name, args, body) = pure $ (`Term.ann` t) <$> mkBinding name args body
|
|
||||||
|
|
||||||
bindingEqBody :: Parser (Term v) -> Parser (Term v)
|
|
||||||
bindingEqBody p = eq *> body
|
bindingEqBody p = eq *> body
|
||||||
where
|
where
|
||||||
eq = token (char '=')
|
eq = token (char '=')
|
||||||
body = lineErrorUnless "parse error in body of binding" p
|
body = lineErrorUnless "parse error in body of binding" p
|
||||||
|
|
||||||
-- a wordyId isn't all digits, and isn't all symbols
|
infixVar :: Var v => Parser s v
|
||||||
wordyId :: Parser String
|
infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId keywords)
|
||||||
wordyId = token $ f <$> id <*> optional ((:) <$> dot <*> wordyId)
|
|
||||||
where
|
where
|
||||||
dot = char '.'
|
backticked = char '`' *> wordyId keywords <* token (char '`')
|
||||||
id = identifier [any (not.isDigit), any isAlphaNum, (`notElem` keywords)]
|
|
||||||
f id rest = maybe id (id++) rest
|
|
||||||
|
|
||||||
-- a symbolyId is all symbols
|
prefixVar :: Var v => Parser s v
|
||||||
symbolyId :: Parser String
|
|
||||||
symbolyId = token $ identifier'
|
|
||||||
[notReservedChar, not . isSpace, \c -> isSymbol c || isPunctuation c]
|
|
||||||
[(`notElem` keywords)]
|
|
||||||
|
|
||||||
infixVar :: Var v => Parser v
|
|
||||||
infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId)
|
|
||||||
where
|
|
||||||
backticked = char '`' *> wordyId <* token (char '`')
|
|
||||||
|
|
||||||
|
|
||||||
prefixVar :: Var v => Parser v
|
|
||||||
prefixVar = (Var.named . Text.pack) <$> prefixOp
|
prefixVar = (Var.named . Text.pack) <$> prefixOp
|
||||||
where
|
where
|
||||||
prefixOp :: Parser String
|
prefixOp = wordyId keywords <|> (char '(' *> symbolyId keywords <* token (char ')')) -- no whitespace w/in parens
|
||||||
prefixOp = wordyId <|> (char '(' *> symbolyId <* token (char ')')) -- no whitespace w/in parens
|
|
||||||
|
|
||||||
prefixTerm :: Var v => Parser (Term v)
|
prefixTerm :: Var v => Parser (S v) (Term v)
|
||||||
prefixTerm = Term.var <$> prefixVar
|
prefixTerm = Term.var <$> prefixVar
|
||||||
|
|
||||||
keywords :: Set String
|
keywords :: [String]
|
||||||
keywords = Set.fromList ["let", "rec", "in", "->", ":", "=", "where"]
|
keywords = ["alias", "do", "let", "rec", "in", "->", ":", "=", "where", "else", "then"]
|
||||||
|
|
||||||
lam :: Var v => Parser (Term v) -> Parser (Term v)
|
lam :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
|
||||||
lam p = Term.lam'' <$> vars <* arrow <*> body
|
lam p = Term.lam'' <$> vars <* arrow <*> body
|
||||||
where
|
where
|
||||||
vars = some prefixVar
|
vars = some prefixVar
|
||||||
arrow = token (string "->")
|
arrow = token (string "->")
|
||||||
body = p
|
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
|
prefixApp p = f <$> some p
|
||||||
where
|
where
|
||||||
f (func:args) = Term.apps func args
|
f (func:args) = Term.apps func args
|
||||||
f [] = error "'some' shouldn't produce an empty list"
|
f [] = error "'some' shouldn't produce an empty list"
|
||||||
|
|
||||||
bindings :: (Var v, Show v) => Parser (Term v) -> Parser [(v, Term v)]
|
alias :: Var v => Parser (S v) ()
|
||||||
bindings p = --many (binding term)
|
alias = do
|
||||||
sepBy1 (token (char ';' <|> char '\n')) (prefixBinding p <|> infixBinding p)
|
_ <- token (string "alias")
|
||||||
|
scope "alias" . commit $ do
|
||||||
|
(fn:params) <- some (Var.named . Text.pack <$> wordyId keywords)
|
||||||
|
_ <- token (string "=")
|
||||||
|
body <- TypeParser.type_
|
||||||
|
semicolon
|
||||||
|
TypeParser.Aliases s <- get
|
||||||
|
let s' = (fn, apply)
|
||||||
|
apply args | length args <= length params = ABT.substs (params `zip` args) body
|
||||||
|
apply args = apply (take n args) `Type.apps` drop n args
|
||||||
|
n = length params
|
||||||
|
set (TypeParser.Aliases (s':s))
|
||||||
|
|
||||||
|
bindings :: Var v => Parser (S v) (Term v) -> Parser (S v) [(v, Term v)]
|
||||||
|
bindings p = do s0 <- get; some (binding <* semicolon) <* set s0 where
|
||||||
|
binding = do
|
||||||
|
_ <- many alias
|
||||||
|
typ <- optional (typedecl <* semicolon)
|
||||||
|
(name, args) <- ( (\arg1 op arg2 -> (op,[arg1,arg2]))
|
||||||
|
<$> prefixVar <*> infixVar <*> prefixVar)
|
||||||
|
<|> ((,) <$> prefixVar <*> many prefixVar)
|
||||||
|
body <- bindingEqBody term
|
||||||
|
case typ of
|
||||||
|
Nothing -> pure $ mkBinding name args body
|
||||||
|
Just (nameT, typ)
|
||||||
|
| name == nameT -> case mkBinding name args body of (v,body) -> pure (v, Term.ann body typ)
|
||||||
|
| otherwise -> fail ("The type signature for ‘" ++ show (Var.name nameT) ++ "’ lacks an accompanying binding")
|
||||||
|
|
||||||
|
mkBinding f [] body = (f, body)
|
||||||
|
mkBinding f args body = (f, Term.lam'' args body)
|
||||||
|
|
||||||
|
moduleBindings :: Var v => Parser (S v) [(v, Term v)]
|
||||||
|
moduleBindings = root (bindings term3)
|
||||||
|
@ -12,6 +12,7 @@ module Unison.Type where
|
|||||||
|
|
||||||
import Data.Aeson (ToJSON(..), FromJSON(..))
|
import Data.Aeson (ToJSON(..), FromJSON(..))
|
||||||
import Data.Aeson.TH
|
import Data.Aeson.TH
|
||||||
|
import Data.List
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
@ -143,6 +144,9 @@ builtin = ref . Reference.Builtin
|
|||||||
app :: Ord v => Type v -> Type v -> Type v
|
app :: Ord v => Type v -> Type v -> Type v
|
||||||
app f arg = ABT.tm (App f arg)
|
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 :: Ord v => Type v -> Type v -> Type v
|
||||||
arrow i o = ABT.tm (Arrow i o)
|
arrow i o = ABT.tm (Arrow i o)
|
||||||
|
|
||||||
|
@ -1,55 +1,83 @@
|
|||||||
|
{-# Language OverloadedStrings #-}
|
||||||
|
|
||||||
module Unison.TypeParser where
|
module Unison.TypeParser where
|
||||||
|
|
||||||
import Control.Applicative ((<|>), some)
|
import Control.Monad
|
||||||
|
import Control.Applicative ((<|>), some, many)
|
||||||
import Data.Char (isUpper, isLower, isAlpha)
|
import Data.Char (isUpper, isLower, isAlpha)
|
||||||
import Data.List (foldl1')
|
|
||||||
import Data.Foldable (asum)
|
import Data.Foldable (asum)
|
||||||
import qualified Data.Text as Text
|
import Data.Functor
|
||||||
|
import Data.List
|
||||||
import Unison.Parser
|
import Unison.Parser
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
|
import qualified Data.Text as Text
|
||||||
import qualified Unison.Type as Type
|
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
|
type_ = forall type1 <|> type1
|
||||||
|
|
||||||
typeLeaf :: Var v => Parser (Type v)
|
typeLeaf :: Var v => Parser (S v) (Type v)
|
||||||
typeLeaf =
|
typeLeaf =
|
||||||
asum [ literal
|
asum [ literal
|
||||||
, parenthesized type_
|
, tupleOrParenthesized type_
|
||||||
, fmap (Type.v' . Text.pack) (token varName)
|
, 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
|
type1 = arrow type2
|
||||||
|
|
||||||
type2 :: Var v => Parser (Type v)
|
type2 :: Var v => Parser (S v) (Type v)
|
||||||
type2 = app typeLeaf
|
type2 = app typeLeaf
|
||||||
|
|
||||||
-- "TypeA TypeB TypeC"
|
-- "TypeA TypeB TypeC"
|
||||||
app :: Ord v => Parser (Type v) -> Parser (Type v)
|
app :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
|
||||||
app rec = fmap (foldl1' Type.app) (some rec)
|
app rec = get >>= \(Aliases aliases) -> do
|
||||||
|
(hd:tl) <- some rec
|
||||||
|
pure $ case hd of
|
||||||
|
Type.Var' v -> case lookup v aliases of
|
||||||
|
Nothing -> foldl' Type.app hd tl
|
||||||
|
Just apply -> apply tl
|
||||||
|
_ -> foldl' Type.app hd tl
|
||||||
|
|
||||||
arrow :: Ord v => Parser (Type v) -> Parser (Type v)
|
arrow :: Ord v => Parser (S v) (Type v) -> Parser (S v) (Type v)
|
||||||
arrow rec = foldr1 Type.arrow <$> sepBy1 (token $ string "->") rec
|
arrow rec = foldr1 Type.arrow <$> sepBy1 (token $ string "->") rec
|
||||||
|
|
||||||
-- "forall a b . List a -> List b -> Maybe Text"
|
-- "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
|
forall rec = do
|
||||||
_ <- token $ string "forall"
|
(void . token $ string "forall") <|> void (token (char '∀'))
|
||||||
vars <- some $ token varName
|
vars <- some $ token varName
|
||||||
_ <- token (char '.')
|
_ <- token (char '.')
|
||||||
t <- rec
|
t <- rec
|
||||||
pure $ Type.forall' (fmap Text.pack vars) t
|
pure $ Type.forall' (fmap Text.pack vars) t
|
||||||
|
|
||||||
varName :: Parser String
|
varName :: Parser s String
|
||||||
varName = identifier [isLower.head, all isAlpha]
|
varName = do
|
||||||
|
name <- wordyId keywords
|
||||||
|
guard (isLower . head $ name)
|
||||||
|
pure name
|
||||||
|
|
||||||
typeName :: Parser String
|
typeName :: Parser s String
|
||||||
typeName = identifier [isUpper.head]
|
typeName = do
|
||||||
|
name <- wordyId keywords
|
||||||
|
guard (isUpper . head $ name)
|
||||||
|
pure name
|
||||||
|
|
||||||
|
keywords :: [String]
|
||||||
|
keywords = ["forall", "∀"]
|
||||||
|
|
||||||
-- qualifiedTypeName :: Parser String
|
-- qualifiedTypeName :: Parser String
|
||||||
-- qualifiedTypeName = f <$> typeName <*> optional more
|
-- qualifiedTypeName = f <$> typeName <*> optional more
|
||||||
@ -58,9 +86,9 @@ typeName = identifier [isUpper.head]
|
|||||||
-- f first more = maybe first (first++) more
|
-- f first more = maybe first (first++) more
|
||||||
-- more = (:) <$> char '.' <*> qualifiedTypeName
|
-- more = (:) <$> char '.' <*> qualifiedTypeName
|
||||||
|
|
||||||
literal :: Var v => Parser (Type v)
|
literal :: Var v => Parser (S v) (Type v)
|
||||||
literal =
|
literal = scope "literal" . token $
|
||||||
token $ asum [ Type.lit Type.Number <$ string "Number"
|
asum [ Type.lit Type.Number <$ string "Number"
|
||||||
, Type.lit Type.Text <$ string "Text"
|
, Type.lit Type.Text <$ string "Text"
|
||||||
, Type.lit Type.Vector <$ string "Vector"
|
, Type.lit Type.Vector <$ string "Vector"
|
||||||
, (Type.v' . Text.pack) <$> typeName
|
, (Type.v' . Text.pack) <$> typeName
|
||||||
|
@ -477,10 +477,11 @@ annotateLetRecBindings letrec = do
|
|||||||
pure $ (marker, body)
|
pure $ (marker, body)
|
||||||
|
|
||||||
-- | Infer the type of a literal
|
-- | Infer the type of a literal
|
||||||
synthLit :: Ord v => Term.Literal -> Type v
|
synthLit :: Var v => Term.Literal -> Type v
|
||||||
synthLit lit = Type.lit $ case lit of
|
synthLit lit = case lit of
|
||||||
Term.Number _ -> Type.Number
|
Term.Number _ -> Type.lit Type.Number
|
||||||
Term.Text _ -> Type.Text
|
Term.Text _ -> Type.lit Type.Text
|
||||||
|
Term.If -> Type.forall' ["a"] (Type.builtin "Boolean" --> Type.v' "a" --> Type.v' "a" --> Type.v' "a")
|
||||||
|
|
||||||
-- | Synthesize the type of the given term, updating the context in the process.
|
-- | Synthesize the type of the given term, updating the context in the process.
|
||||||
synthesize :: Var v => Term v -> M v (Type v)
|
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
|
go Term.Blank' = do
|
||||||
v <- freshVar
|
v <- freshVar
|
||||||
pure $ Type.forall (TypeVar.Universal v) (Type.universal v)
|
pure $ Type.forall (TypeVar.Universal v) (Type.universal v)
|
||||||
go (Term.Ann' (Term.Ref' _) t) =
|
go (Term.Ann' (Term.Ref' _) t) = case ABT.freeVars t of
|
||||||
|
s | Set.null s ->
|
||||||
-- innermost Ref annotation assumed to be correctly provided by `synthesizeClosed`
|
-- innermost Ref annotation assumed to be correctly provided by `synthesizeClosed`
|
||||||
pure (ABT.vmap TypeVar.Universal t)
|
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.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.Lit' l) = pure (synthLit l) -- 1I=>
|
||||||
go (Term.App' f arg) = do -- ->E
|
go (Term.App' f arg) = do -- ->E
|
||||||
ft <- synthesize f; ctx <- getContext
|
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 :: forall v . Var v => Map.Map Text.Text (Type.Type v)
|
||||||
remoteSignatures = Map.fromList
|
remoteSignatures = Map.fromList
|
||||||
[ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote' (v' "a")))
|
[ ("Remote.at", Type.forall' ["a"] (Type.builtin "Node" --> v' "a" --> remote (v' "a")))
|
||||||
, ("Remote.fork", Type.forall' ["a"] (remote' (v' "a") --> remote' unitT))
|
, ("Remote.fork", Type.forall' ["a"] (remote (v' "a") --> remote unitT))
|
||||||
, ("Remote.here", remote' (Type.builtin "Node"))
|
, ("Remote.here", remote (Type.builtin "Node"))
|
||||||
, ("Remote.spawn", remote' (Type.builtin "Node"))
|
, ("Remote.spawn", remote (Type.builtin "Node"))
|
||||||
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote' unitT))
|
, ("Remote.send", Type.forall' ["a"] (channel (v' "a") --> v' "a" --> remote unitT))
|
||||||
, ("Remote.channel", Type.forall' ["a"] (remote' (channel (v' "a"))))
|
, ("Remote.channel", Type.forall' ["a"] (remote (channel (v' "a"))))
|
||||||
, ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote' (v' "a") --> remote' (v' "b")))
|
, ("Remote.map", Type.forall' ["a","b"] ((v' "a" --> v' "b") --> remote (v' "a") --> remote (v' "b")))
|
||||||
, ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote' (v' "b")) --> remote' (v' "a") --> remote' (v' "b")))
|
, ("Remote.bind", Type.forall' ["a","b"] ((v' "a" --> remote (v' "b")) --> remote (v' "a") --> remote (v' "b")))
|
||||||
, ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote' (v' "a")))
|
, ("Remote.pure", Type.forall' ["a"] (v' "a" --> remote (v' "a")))
|
||||||
, ("Remote.receiveAsync", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote' (remote' (v' "a"))))
|
, ("Remote.receive-async", Type.forall' ["a"] (channel (v' "a") --> timeoutT --> remote (remote (v' "a"))))
|
||||||
, ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote' (v' "a"))) ]
|
, ("Remote.receive", Type.forall' ["a"] (channel (v' "a") --> remote (v' "a"))) ]
|
||||||
where
|
where
|
||||||
v' = Type.v'
|
v' = Type.v'
|
||||||
timeoutT = Type.builtin "Remote.Timeout"
|
timeoutT = Type.builtin "Duration"
|
||||||
unitT = Type.builtin "Unit"
|
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
|
channel t = Type.builtin "Channel" `Type.app` t
|
||||||
|
|
||||||
-- | For purposes of typechecking, we translate `[x,y,z]` to the term
|
-- | For purposes of typechecking, we translate `[x,y,z]` to the term
|
||||||
@ -634,15 +642,19 @@ synthesizeClosed synthRef term = do
|
|||||||
synthesizeClosedAnnotated term
|
synthesizeClosedAnnotated term
|
||||||
|
|
||||||
synthesizeClosed' :: Var v => Term v -> M v (Type v)
|
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
|
Left err -> M $ \_ -> Left err
|
||||||
Right (t,env) -> pure $ generalizeExistentials (ctx env) t
|
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 :: (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) ->
|
Note.fromEither $ runM (synthesize term) env0 >>= \(t,env) ->
|
||||||
-- we generalize over any remaining unsolved existentials
|
-- we generalize over any remaining unsolved existentials
|
||||||
pure $ generalizeExistentials (ctx env) t
|
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
|
-- boring instances
|
||||||
instance Applicative (M v) where
|
instance Applicative (M v) where
|
||||||
|
@ -14,10 +14,10 @@ module Unison.Util.Logger where
|
|||||||
|
|
||||||
import Control.Concurrent (forkIO)
|
import Control.Concurrent (forkIO)
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Exception (finally, try)
|
import Control.Exception (bracket, try)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.List
|
import Data.List
|
||||||
import System.IO (Handle, hPutStrLn, hGetLine)
|
import System.IO (Handle, hPutStrLn, hGetLine, stdout, stderr)
|
||||||
import System.IO.Error (isEOFError)
|
import System.IO.Error (isEOFError)
|
||||||
|
|
||||||
type Level = Int
|
type Level = Int
|
||||||
@ -34,12 +34,18 @@ atomic :: Logger -> IO Logger
|
|||||||
atomic logger = do
|
atomic logger = do
|
||||||
lock <- newMVar ()
|
lock <- newMVar ()
|
||||||
pure $
|
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' }
|
in logger { raw = raw' }
|
||||||
|
|
||||||
toHandle :: Handle -> Logger
|
toHandle :: Handle -> Logger
|
||||||
toHandle h = logger (hPutStrLn h)
|
toHandle h = logger (hPutStrLn h)
|
||||||
|
|
||||||
|
toStandardError :: Logger
|
||||||
|
toStandardError = toHandle stderr
|
||||||
|
|
||||||
|
toStandardOut :: Logger
|
||||||
|
toStandardOut = toHandle stdout
|
||||||
|
|
||||||
logHandleAt :: Logger -> Level -> Handle -> IO ()
|
logHandleAt :: Logger -> Level -> Handle -> IO ()
|
||||||
logHandleAt logger lvl h
|
logHandleAt logger lvl h
|
||||||
| lvl > getLevel logger = pure ()
|
| lvl > getLevel logger = pure ()
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import System.IO
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import qualified Unison.Test.Doc as Doc
|
import qualified Unison.Test.Doc as Doc
|
||||||
import qualified Unison.Test.Typechecker as Typechecker
|
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]
|
tests = testGroup "unison" [Doc.tests, Typechecker.tests, Term.tests, TermParser.tests, TypeParser.tests, Interpreter.tests, Components.tests]
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain tests
|
main = do
|
||||||
|
mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr]
|
||||||
|
defaultMain tests
|
||||||
|
@ -1,30 +1,51 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Unison.Test.Common where
|
module Unison.Test.Common where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Data.Foldable
|
||||||
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
|
import System.IO (FilePath)
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Node (Node)
|
import Unison.Node (Node)
|
||||||
import Unison.Reference (Reference)
|
import Unison.Reference (Reference)
|
||||||
import Unison.Term (Term)
|
import Unison.Term (Term)
|
||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.Views (defaultSymbol)
|
import Unison.Views (defaultSymbol)
|
||||||
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.Map as Map
|
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.Metadata as Metadata
|
||||||
import qualified Unison.Node as Node
|
import qualified Unison.Node as Node
|
||||||
import qualified Unison.Node.MemNode as MemNode
|
import qualified Unison.Node.MemNode as MemNode
|
||||||
import qualified Unison.Note as Note
|
import qualified Unison.Note as Note
|
||||||
import qualified Unison.Term as Term
|
import qualified Unison.Term as Term
|
||||||
import qualified Unison.View as View
|
import qualified Unison.View as View
|
||||||
|
import qualified Unison.Util.Logger as L
|
||||||
|
|
||||||
type V = Symbol View.DFO
|
type V = Symbol View.DFO
|
||||||
-- A Node for testing
|
-- 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 :: IO TNode
|
||||||
node = do
|
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 $
|
symbols <- liftIO . Note.run $
|
||||||
Map.fromList . Node.references <$> Node.search node Term.blank [] 1000 (Metadata.Query "") Nothing
|
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 firstName (Metadata.Names (n:_)) = n
|
||||||
let lookupSymbol ref = maybe (defaultSymbol ref) (firstName . Metadata.names) (Map.lookup ref symbols)
|
let lookupSymbol ref = maybe (defaultSymbol ref) (firstName . Metadata.names) (Map.lookup ref symbols)
|
||||||
pure (node, lookupSymbol)
|
pure (node, lookupSymbol, base)
|
||||||
|
@ -2,7 +2,7 @@ module Unison.Test.Interpreter where
|
|||||||
|
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
import Unison.Parsers (unsafeParseTerm)
|
import qualified Unison.Parsers as P
|
||||||
import qualified Unison.Node as Node
|
import qualified Unison.Node as Node
|
||||||
import qualified Unison.Note as Note
|
import qualified Unison.Note as Note
|
||||||
import qualified Unison.Test.Common as Common
|
import qualified Unison.Test.Common as Common
|
||||||
@ -14,28 +14,89 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
|||||||
[ t "1 + 1" "2"
|
[ t "1 + 1" "2"
|
||||||
, t "1 + 1 + 1" "3"
|
, t "1 + 1 + 1" "3"
|
||||||
, t "(x -> x) 42" "42"
|
, t "(x -> x) 42" "42"
|
||||||
, t "let x = 2; y = 3 in x + y" "5"
|
, t "let x = 2; y = 3 ; x + y;;" "5"
|
||||||
, t "if False 0 1" "1"
|
, t "if False then 0 else 1" "1"
|
||||||
, t "if True 12 13" "12"
|
, t "if True then 12 else 13" "12"
|
||||||
, t "1 > 0" "True"
|
, t "1 >_Number 0" "True"
|
||||||
, t "1 == 1" "True"
|
, t "1 ==_Number 1" "True"
|
||||||
, t "2 == 0" "False"
|
, t "2 ==_Number 0" "False"
|
||||||
, t "1 < 2" "True"
|
, t "1 <_Number 2" "True"
|
||||||
, t "1 <= 1" "True"
|
, t "1 <=_Number 1" "True"
|
||||||
, t "1 >= 1" "True"
|
, t "1 >=_Number 1" "True"
|
||||||
, t "let rec fac n = if (n == 0) 1 (n * fac (n - 1)) in fac 5" "120"
|
, t "Comparison.fold 1 0 0 Less" "1"
|
||||||
, t "let rec ping n = if (n >= 10) n (pong (n + 1)); pong n = ping (n + 1) in ping 0"
|
, t "Comparison.fold 0 1 0 Equal" "1"
|
||||||
|
, t "Comparison.fold 0 0 1 Greater" "1"
|
||||||
|
, t "Order.compare (Order.invert <| Order.tuple2 Number.Order Number.Order) (1,2) (1,3)" "Greater"
|
||||||
|
, t "Order.compare (Order.invert <| Order.tuple2 Number.Order Number.Order) (2,1) (1,3)" "Less"
|
||||||
|
, t "Order.compare (Order.tuple2 Number.Order Order.ignore) (1,2) (1,3)" "Equal"
|
||||||
|
, t "Order.compare (Order.tuple2 Order.ignore Number.Order ) (2,2) (1,3)" "Less"
|
||||||
|
, t "True `or` False" "True"
|
||||||
|
, t "False `or` True" "True"
|
||||||
|
, t "True `or` True" "True"
|
||||||
|
, t "False `or` False" "False"
|
||||||
|
, t "True `and` True" "True"
|
||||||
|
, t "True `and` False" "False"
|
||||||
|
, t "False `and` True" "False"
|
||||||
|
, t "False `and` False" "False"
|
||||||
|
, t "not False" "True"
|
||||||
|
, t "not True" "False"
|
||||||
|
, t "let rec fac n = if n ==_Number 0 then 1 else n * fac (n - 1); fac 5;;" "120"
|
||||||
|
, t "let rec ping n = if n >=_Number 10 then n else pong (n + 1); pong n = ping (n + 1); ping 0;;"
|
||||||
"10"
|
"10"
|
||||||
, t "let id x = x; g = id 42; p = id \"hi\" in g" "42"
|
, t "let id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
|
||||||
, t "let id : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" in g" "42"
|
, t "let id : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
|
||||||
, t "((let id x = x in id) : forall a . a -> a) 42" "42"
|
, t "(let id x = x; id;; : forall a . a -> a) 42" "42"
|
||||||
|
, t "Optional.map ((+) 1) (Some 1)" "Some 2"
|
||||||
|
, t "Optional.map ((+) 1) ((Some: ∀ a . a -> Optional a) 1)" "Some 2"
|
||||||
|
, t "Either.fold ((+) 1) ((+) 2) (Left 1)" "2"
|
||||||
|
, t "Either.fold ((+) 1) ((+) 2) (Right 1)" "3"
|
||||||
|
, t "Either.swap (Left 1)" "Either.Right 1"
|
||||||
|
, t "Pair.fold (x y -> x) (1, 2)" "1"
|
||||||
|
, t "const 41 0" "41"
|
||||||
|
, t "1st (1,2,3,4)" "1"
|
||||||
|
, t "2nd (1,2 + 1,3,4)" "3"
|
||||||
|
, t "identity <| (1 + 1)" "2"
|
||||||
|
, t "(1 + 1) |> identity" "2"
|
||||||
|
, t "if \"hi\" ==_Text \"hi\" then 1 else 2" "1"
|
||||||
|
, t "if \"hi\" <_Text \"hiya\" then 1 else 2" "1"
|
||||||
|
, t "if \"hi\" <=_Text \"hiya\" then 1 else 2" "1"
|
||||||
|
, t "if \"hiya\" >_Text \"hi\" then 1 else 2" "1"
|
||||||
|
, t "if \"hiya\" >=_Text \"hi\" then 1 else 2" "1"
|
||||||
|
, t "if \"hi\" >=_Text \"hi\" then 1 else 2" "1"
|
||||||
|
, t "if \"hi\" <=_Text \"hi\" then 1 else 2" "1"
|
||||||
|
, t "Vector.reverse [1,2,3]" "[3,2,1]"
|
||||||
|
, t "Vector.reverse Vector.empty" "[]"
|
||||||
|
, t "Vector.fold-right Vector.prepend Vector.empty [1,2,3]" "[1,2,3]"
|
||||||
|
, t "Vector.fold-balanced Vector.concatenate Vector.empty (Vector.map Vector.single [1,2,3,4,5])"
|
||||||
|
"[1,2,3,4,5]"
|
||||||
|
, t "Vector.fold-balanced Vector.concatenate Vector.empty [[1],[2],[3,4],[5]]"
|
||||||
|
"[1,2,3,4,5]"
|
||||||
|
, t "Vector.fold-balanced (+) 0 [1,2,3]" "6"
|
||||||
|
, t "Vector.dedup-adjacent (==_Number) [1,1,2,2,3,4,4,4,4,5]" "[1,2,3,4,5]"
|
||||||
|
, t "Vector.dedup Number.Order [1,2,1,5,4,2,4,4,3,5]" "[1,2,3,4,5]"
|
||||||
|
, t "Vector.histogram Number.Order [1,2,1,5,4,2,4,4,3,5]" "[(1,2),(2,2),(3,1),(4,3),(5,2)]"
|
||||||
|
, t "Vector.ranked-histogram Number.Order [1,2,1,5,4,2,4,4,3,5]"
|
||||||
|
"[(4,3),(1,2),(2,2),(5,2),(3,1)]"
|
||||||
|
, t "Vector.range 0 10" "[0,1,2,3,4,5,6,7,8,9]"
|
||||||
|
, t "Vector.range 0 0" "[]"
|
||||||
|
, t "Vector.fold-left (+) 0 (Vector.replicate 5 1)" "5"
|
||||||
|
, t "Vector.sort-by Number.Order identity [5,2,1,3,4]" "[1,2,3,4,5]"
|
||||||
|
, t "Vector.sort-by (Order.invert Number.Order) identity [5,2,1,3,4]" "[5,4,3,2,1]"
|
||||||
|
, t "Vector.bind 2nd (Vector.zip [1,2,3] [[1],[2],[3]])" "[1,2,3]"
|
||||||
|
, t "Vector.all? identity [True,True,True,True]" "True"
|
||||||
|
, t "Vector.all? identity [True,False,True,True]" "False"
|
||||||
|
, t "Optional.get-or 96 (Vector.at 1 [0,1,2,3,4])" "1"
|
||||||
|
, t "Vector.take 0 [1,2,3]" "[]"
|
||||||
|
, t "Vector.take 2 [1,2,3]" "[1,2]"
|
||||||
|
, t "Vector.drop 2 [1,2,3]" "[3]"
|
||||||
]
|
]
|
||||||
t uneval eval = testCase (uneval ++ " ⟹ " ++ eval) $ do
|
t uneval eval = testCase (uneval ++ " ⟹ " ++ eval) $ do
|
||||||
(node, _) <- node
|
(node, _, builtins) <- node
|
||||||
let term = unsafeParseTerm uneval
|
-- putStrLn (show $ map fst builtins)
|
||||||
|
let term = P.bindBuiltins builtins [] $ P.unsafeParseTerm uneval
|
||||||
_ <- Note.run $ Node.typeAt node term []
|
_ <- Note.run $ Node.typeAt node term []
|
||||||
[(_,_,result)] <- Note.run $ Node.evaluateTerms node [([], unsafeParseTerm uneval)]
|
[(_,_,result)] <- Note.run $ Node.evaluateTerms node [([], term)]
|
||||||
assertEqual "comparing results" (unsafeParseTerm eval) result
|
assertEqual "comparing results" (P.unsafeParseTerm eval) result
|
||||||
in testGroup "Interpreter" tests
|
in testGroup "Interpreter" tests
|
||||||
|
|
||||||
main = defaultMain tests
|
main = defaultMain tests
|
||||||
|
@ -32,7 +32,7 @@ hash :: TTerm -> Hash
|
|||||||
hash = ABT.hash
|
hash = ABT.hash
|
||||||
|
|
||||||
atPts :: Bool -> Common.TNode -> [(Int,Int)] -> TTerm -> [(Paths.Path, Region)]
|
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)
|
go (x,y) = let p = path x y in (p, Doc.region bounds p)
|
||||||
doc = Views.term symbol t
|
doc = Views.term symbol t
|
||||||
layout = Doc.layout Doc.textWidth (Width 80) doc
|
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))
|
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
|
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 :: TestTree
|
||||||
tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term"
|
tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term"
|
||||||
[ testCase "alpha equivalence (term)" $ assertEqual "identity"
|
[ testCase "alpha equivalence (term)" $ assertEqual "identity"
|
||||||
@ -48,56 +51,56 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term"
|
|||||||
, testCase "hash cycles" $ assertEqual "pingpong"
|
, testCase "hash cycles" $ assertEqual "pingpong"
|
||||||
(hash pingpong1)
|
(hash pingpong1)
|
||||||
(hash pingpong2)
|
(hash pingpong2)
|
||||||
, testCase "infix-rendering (1)" $ node >>= \(_,symbol) ->
|
-- , testCase "infix-rendering (1)" $ node >>= \(_,symbol,_) ->
|
||||||
let t = unsafeParseTerm "Number.plus 1 1"
|
-- let t = unsafeParseTerm "Number.plus 1 1"
|
||||||
in assertEqual "+"
|
-- in assertEqual "+"
|
||||||
"1 + 1"
|
-- "1 + 1"
|
||||||
(Doc.formatText (Width 80) (Views.term symbol t))
|
-- (Doc.formatText (Width 80) (Views.term symbol t))
|
||||||
, testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol) ->
|
-- , testCase "infix-rendering (unsaturated)" $ node >>= \(_,symbol,_) ->
|
||||||
let t = unsafeParseTerm "Number.plus _"
|
-- let t = unsafeParseTerm "Number.plus _"
|
||||||
in assertEqual "+"
|
-- in assertEqual "+"
|
||||||
"(+) _"
|
-- "(+) _"
|
||||||
(Doc.formatText (Width 80) (Views.term symbol t))
|
-- (Doc.formatText (Width 80) (Views.term symbol t))
|
||||||
, testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol) ->
|
-- , testCase "infix-rendering (totally unsaturated)" $ node >>= \(_,symbol,_) ->
|
||||||
let t = unsafeParseTerm "Number.plus"
|
-- let t = unsafeParseTerm "Number.plus"
|
||||||
in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
|
-- in assertEqual "+" "(+)" (Doc.formatText (Width 80) (Views.term symbol t))
|
||||||
, testCase "infix-rendering (2)" $ node >>= \(_,symbol) ->
|
-- , testCase "infix-rendering (2)" $ node >>= \(_,symbol,_) ->
|
||||||
do
|
-- do
|
||||||
t <- pure $ unsafeParseTerm "Number.plus 1 1"
|
-- t <- pure $ unsafeParseTerm "Number.plus 1 1"
|
||||||
let d = Views.term symbol t
|
-- let d = Views.term symbol t
|
||||||
assertEqual "path sanity check"
|
-- assertEqual "path sanity check"
|
||||||
[Paths.Fn,Paths.Arg]
|
-- [Paths.Fn,Paths.Arg]
|
||||||
(head $ Doc.leafPaths d)
|
-- (head $ Doc.leafPaths d)
|
||||||
, testCase "let-rendering (1)" $ node >>= \node ->
|
-- , testCase "let-rendering (1)" $ node >>= \node ->
|
||||||
do
|
-- do
|
||||||
-- let xy = 4223 in 42
|
-- -- let xy = 4223 in 42
|
||||||
t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
|
-- t <- pure $ unsafeParseTerm "let xy = 4223 in 42"
|
||||||
[(p1,r1), (p2,_), (p3,r3), (p4,_), (p5,r5), (p6,r6)] <- pure $
|
-- [(p1,r1), (p2,_), (p3,r3), (p4,_), (p5,r5), (p6,r6)] <- pure $
|
||||||
atPts False node [(0,0), (1,0), (10,0), (11,0), (5,0), (8,0)] t
|
-- atPts False node [(0,0), (1,0), (10,0), (11,0), (5,0), (8,0)] t
|
||||||
assertEqual "p1" [] p1
|
-- assertEqual "p1" [] p1
|
||||||
assertEqual "p2" [] p2
|
-- assertEqual "p2" [] p2
|
||||||
assertEqual "r1" (rect 0 0 19 1) r1
|
-- assertEqual "r1" (rect 0 0 19 1) r1
|
||||||
assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
|
-- assertEqual "p3" [Paths.Binding 0, Paths.Body] p3
|
||||||
assertEqual "r3" (rect 9 0 4 1) r3
|
-- assertEqual "r3" (rect 9 0 4 1) r3
|
||||||
assertEqual "p3 == p4" p3 p4
|
-- assertEqual "p3 == p4" p3 p4
|
||||||
assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
|
-- assertEqual "p5" [Paths.Binding 0, Paths.Bound] p5
|
||||||
assertEqual "r5" (rect 4 0 2 1) r5
|
-- assertEqual "r5" (rect 4 0 2 1) r5
|
||||||
assertEqual "p6" [Paths.Binding 0] p6
|
-- assertEqual "p6" [Paths.Binding 0] p6
|
||||||
assertEqual "r6" (rect 4 0 9 1) r6
|
-- assertEqual "r6" (rect 4 0 9 1) r6
|
||||||
, testCase "map lambda rendering" $ node >>= \node ->
|
-- , testCase "map lambda rendering" $ node >>= \node ->
|
||||||
do
|
-- do
|
||||||
-- map (x -> _) [1,2,3]
|
-- -- map (x -> _) [1,2,3]
|
||||||
t <- pure $ builtin "Vector.map" `app` lam' ["x"] blank `app` vector (map num [1,2,3])
|
-- t <- pure $ builtin "Vector.map" `app` lam' ["x"] blank `app` vector (map num [1,2,3])
|
||||||
[(p1,r1)] <- pure $ atPts False node [(5,0)] t
|
-- [(p1,r1)] <- pure $ atPts False node [(5,0)] t
|
||||||
assertEqual "p1" [Paths.Fn, Paths.Arg] p1
|
-- assertEqual "p1" [Paths.Fn, Paths.Arg] p1
|
||||||
assertEqual "r1" (rect 4 0 8 1) r1
|
-- assertEqual "r1" (rect 4 0 8 1) r1
|
||||||
, testCase "operator chain rendering" $ node >>= \node ->
|
-- , testCase "operator chain rendering" $ node >>= \node ->
|
||||||
do
|
-- do
|
||||||
t <- pure $ unsafeParseTerm "1 + 2 + 3"
|
-- t <- pure $ unsafeParseTerm "1 + 2 + 3"
|
||||||
[(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
|
-- [(p1,r1),(p2,_)] <- pure $ atPts False node [(1,0), (2,0)] t
|
||||||
assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
|
-- assertEqual "p1" [Paths.Fn, Paths.Arg, Paths.Fn, Paths.Arg] p1
|
||||||
assertEqual "r1" (rect 0 0 1 1) r1
|
-- assertEqual "r1" (rect 0 0 1 1) r1
|
||||||
assertEqual "p2" [] p2
|
-- assertEqual "p2" [] p2
|
||||||
]
|
]
|
||||||
|
|
||||||
rect :: Int -> Int -> Int -> Int -> (X,Y,Width,Height)
|
rect :: Int -> Int -> Int -> Int -> (X,Y,Width,Height)
|
||||||
@ -108,15 +111,12 @@ rect x y w h =
|
|||||||
pingpong1 :: TTerm
|
pingpong1 :: TTerm
|
||||||
pingpong1 =
|
pingpong1 =
|
||||||
unsafeParseTerm $
|
unsafeParseTerm $
|
||||||
unlines [ "let rec ping = x -> pong (x + 1)"
|
unlines [ "let rec "
|
||||||
, " ; pong = y -> ping (y - 1)"
|
, " ping x = pong (x + 1);"
|
||||||
, " in ping 1"
|
, " pong y = ping (y - 1);"
|
||||||
|
, " ping 1;;"
|
||||||
]
|
]
|
||||||
|
|
||||||
pingpong2 :: TTerm
|
pingpong2 :: TTerm
|
||||||
pingpong2 =
|
pingpong2 =
|
||||||
unsafeParseTerm $
|
unsafeParseTerm $ "let rec pong1 p = ping1 (p - 1); ping1 q = pong1 (q + 1); ping1 1;;"
|
||||||
unlines [ "let rec pong1 = p -> ping1 (p - 1)"
|
|
||||||
, " ; ping1 = q -> pong1 (q + 1)"
|
|
||||||
, " in ping1 1"
|
|
||||||
]
|
|
||||||
|
@ -1,6 +1,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Unison.Test.TermParser where
|
module Unison.Test.TermParser where
|
||||||
|
|
||||||
|
import Data.List
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
@ -15,11 +16,17 @@ import qualified Unison.Type as T
|
|||||||
-- import Test.Tasty.SmallCheck as SC
|
-- import Test.Tasty.SmallCheck as SC
|
||||||
-- import Test.Tasty.QuickCheck as QC
|
-- 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 :: (String, Term (Symbol DFO)) -> TestTree
|
||||||
parse (s, expected) =
|
parse (s, expected) =
|
||||||
testCase ("`" ++ s ++ "`") $
|
testCase ("`" ++ s ++ "`") $
|
||||||
case parseTerm s of
|
case parseTerm s of
|
||||||
Fail _ _ -> assertFailure "parse failure"
|
Fail e _ -> assertFailure $ "parse failure " ++ intercalate "\n" e
|
||||||
Succeed a _ _ -> assertEqual "mismatch" expected a
|
Succeed a _ _ -> assertEqual "mismatch" expected a
|
||||||
|
|
||||||
parseFail :: (String,String) -> TestTree
|
parseFail :: (String,String) -> TestTree
|
||||||
@ -27,16 +34,20 @@ parseFail (s, reason) =
|
|||||||
testCase ("`" ++ s ++ "` shouldn't parse: " ++ reason) $ assertBool "should not have parsed" $
|
testCase ("`" ++ s ++ "` shouldn't parse: " ++ reason) $ assertBool "should not have parsed" $
|
||||||
case parseTerm s of
|
case parseTerm s of
|
||||||
Fail {} -> True;
|
Fail {} -> True;
|
||||||
Succeed _ n _ -> n == length s;
|
Succeed _ _ n -> n == length s;
|
||||||
|
|
||||||
tests :: TestTree
|
tests :: TestTree
|
||||||
tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> shouldFail)
|
tests = testGroup "TermParser" $ (parse <$> shouldPass)
|
||||||
|
++ (parse' <$> shouldParse)
|
||||||
|
++ (parseFail <$> shouldFail)
|
||||||
where
|
where
|
||||||
shouldFail =
|
shouldFail =
|
||||||
[ ("+", "operator needs to be enclosed in parens or between arguments")
|
[ ("+", "operator needs to be enclosed in parens or between arguments")
|
||||||
, ("#V-fXHD3-N0E", "invalid base64url")
|
, ("#V-fXHD3-N0E", "invalid base64url")
|
||||||
, ("#V-f/XHD3-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 =
|
shouldPass =
|
||||||
[ ("1", one)
|
[ ("1", one)
|
||||||
, ("[1,1]", vector [one, 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", onenone)
|
, ("1+1", onenone)
|
||||||
, ("1+ 1", app (var' "1+") one)
|
, ("1+ 1", app (var' "1+") one)
|
||||||
, ("1 +1", app one (var' "+1"))
|
-- todo: failing
|
||||||
|
-- , ("1 +1", app one (var' "+1"))
|
||||||
, ("[1+1]", vector [onenone])
|
, ("[1+1]", vector [onenone])
|
||||||
, ("\"hello\"", hello)
|
, ("\"hello\"", hello)
|
||||||
, ("_", blank)
|
, ("_", blank)
|
||||||
, ("a", a)
|
, ("a", a)
|
||||||
, ("Number.plus", numberplus)
|
, ("(+_Number)", numberplus)
|
||||||
, ("Number.Other.plus", var' "Number.Other.plus")
|
, ("Number.Other.plus", var' "Number.Other.plus")
|
||||||
, ("f -> Remote.bind (#V-fXHD3-N0E= Remote.pure f)", remoteMap)
|
, ("f -> Remote.bind (#V-fXHD3-N0E= Remote.pure f)", remoteMap)
|
||||||
, ("1:Int", ann one int)
|
, ("1:Int", ann one int)
|
||||||
, ("(1:Int)", ann one int)
|
, ("(1:Int)", ann one int)
|
||||||
, ("(1:Int) : Int", ann (ann one int) int)
|
, ("(1:Int) : Int", ann (ann one int) int)
|
||||||
, ("let a = 1 in a + 1", let1' [("a", one)] (apps numberplus [a, one]))
|
, ("let a = 1; a + 1;;", let1' [("a", one)] (apps numberplus [a, one]))
|
||||||
, ("let a : Int; a = 1 in a + 1", let_a_int1_in_aplus1)
|
, ("let a : Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
|
||||||
, ("let a: Int; a = 1 in a + 1", let_a_int1_in_aplus1)
|
, ("let a: Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
|
||||||
, ("let a :Int; a = 1 in a + 1", let_a_int1_in_aplus1)
|
, ("let a :Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
|
||||||
, ("let a:Int; a = 1 in a + 1", let_a_int1_in_aplus1)
|
, ("let a:Int; a = 1; a + 1;;", let_a_int1_in_aplus1)
|
||||||
, ("a b -> a + b", lam_ab_aplusb)
|
, ("a b -> a + b", lam_ab_aplusb)
|
||||||
, ("(a b -> a + b) : Int -> Int -> Int", ann lam_ab_aplusb intintint)
|
, ("(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 b -> a + b : Int", lam' ["a", "b"] (ann (apps numberplus [a, b]) int))
|
||||||
, ("a -> a", lam' ["a"] a)
|
, ("a -> a", lam' ["a"] a)
|
||||||
, ("(a -> a) : forall a . a -> a", ann (lam' ["a"] a) (T.forall' ["a"] (T.arrow a' a')))
|
, ("(a -> a) : forall a . a -> a", ann (lam' ["a"] a) (T.forall' ["a"] (T.arrow a' a')))
|
||||||
, ("let f = a b -> a + b in f 1 1", f_eq_lamab_in_f11)
|
, ("let f = a b -> a + b; f 1 1;;", f_eq_lamab_in_f11)
|
||||||
, ("let f a b = a + b in f 1 1", f_eq_lamab_in_f11)
|
, ("let f a b = a + b; f 1 1;;", f_eq_lamab_in_f11)
|
||||||
, ("let f (+) b = 1 + b in f g 1", let1' [("f", lam' ["+", "b"] (apps plus [one, b]))] (apps f [g,one]))
|
, ("let f (+) b = 1 + b; f g 1;;", let1' [("f", lam' ["+", "b"] (apps plus [one, b]))] (apps f [g,one]))
|
||||||
, ("let a + b = f a b in 1 + 1", let1' [("+", lam' ["a", "b"] fab)] one_plus_one)
|
, ("let a + b = f a b; 1 + 1;;", let1' [("+", lam' ["a", "b"] fab)] one_plus_one)
|
||||||
, ("let (+) : Int -> Int -> Int; a + b = f a b in 1 + 1", plusintintint_fab_in_1plus1)
|
, ("let (+) : Int -> Int -> Int; a + b = f a b; 1 + 1;;", plusintintint_fab_in_1plus1)
|
||||||
, ("let (+) : Int -> Int -> Int; (+) a b = f a b in 1 + 1", plusintintint_fab_in_1plus1)
|
, ("let (+) : Int -> Int -> Int; (+) a b = f a b; 1 + 1;;", plusintintint_fab_in_1plus1)
|
||||||
, ("let (+) : Int -> Int -> Int; (+) a b = f a b in (+) 1 1", plusintintint_fab_in_1plus1)
|
, ("let (+) : Int -> Int -> Int; (+) a b = f a b; (+) 1 1;;", plusintintint_fab_in_1plus1)
|
||||||
, ("let f b = b + 1; a = 1 in (+) a (f 1)", let1' [("f", lam_b_bplus1), ("a", one)] (apps numberplus [a, apps f [one]]))
|
, ("let f b = b + 1; a = 1; (+) a (f 1);;", let1' [("f", lam_b_bplus1), ("a", one)] (apps numberplus [a, apps f [one]]))
|
||||||
-- from Unison.Test.Term
|
-- from Unison.Test.Term
|
||||||
, ("a -> a", lam' ["a"] $ var' "a") -- id
|
, ("a -> a", lam' ["a"] $ var' "a") -- id
|
||||||
, ("x y -> x", lam' ["x", "y"] $ var' "x") -- const
|
, ("x y -> x", lam' ["x", "y"] $ var' "x") -- const
|
||||||
, ("let rec fix = f -> f (fix f) in fix", fix) -- fix
|
, ("let rec fix = f -> f (fix f); fix;;", fix) -- fix
|
||||||
, ("let rec fix f = f (fix f) in fix", fix) -- fix
|
, ("let rec fix f = f (fix f); fix;;", fix) -- fix
|
||||||
, ("1 + 2 + 3", num 1 `plus'` num 2 `plus'` num 3)
|
, ("1 + 2 + 3", num 1 `plus'` num 2 `plus'` num 3)
|
||||||
, ("[1, 2, 1 + 1]", vector [num 1, num 2, num 1 `plus'` num 1])
|
, ("[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),
|
[ ("x", var' "id" `app` num 42),
|
||||||
("y", var' "id" `app` text "hi")
|
("y", var' "id" `app` text "hi")
|
||||||
] (num 43)) `ann` (T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number))
|
] (num 43)) `ann` (T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number))
|
||||||
, ("#" ++ Text.unpack sampleHash64, derived' sampleHash64)
|
, ("#" ++ Text.unpack sampleHash64, derived' sampleHash64)
|
||||||
, ("#" ++ Text.unpack sampleHash512, derived' sampleHash512)
|
, ("#" ++ Text.unpack sampleHash512, derived' sampleHash512)
|
||||||
, ("(Remote { pure 42; })", builtin "Remote.pure" `app` num 42)
|
, ("(do Remote pure 42;;)", builtin "Remote.pure" `app` num 42)
|
||||||
, ("Remote { x = 42; pure (x + 1); }",
|
, ("do Remote x = 42; pure (x + 1) ;;",
|
||||||
builtin "Remote.bind" `apps` [
|
builtin "Remote.bind" `apps` [
|
||||||
lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
|
lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
|
||||||
builtin "Remote.pure" `app` num 42
|
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` [
|
builtin "Remote.bind" `apps` [
|
||||||
lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
|
lam' ["q"] (builtin "Remote.pure" `app` (var' "q" `plus'` num 1)),
|
||||||
builtin "Remote.pure" `app` num 42
|
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` [
|
builtin "Remote.bind" `apps` [
|
||||||
lam' ["x"] (builtin "Remote.bind" `apps` [
|
lam' ["x"] (builtin "Remote.bind" `apps` [
|
||||||
lam' ["y"] (builtin "Remote.pure" `app` (var' "x" `plus'` var' "y")),
|
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"
|
f = var' "f"
|
||||||
g = var' "g"
|
g = var' "g"
|
||||||
plus = var' "+"
|
plus = var' "+"
|
||||||
plus' x y = builtin "Number.plus" `app` x `app` y
|
plus' x y = builtin "Number.+" `app` x `app` y
|
||||||
numberplus = builtin "Number.plus"
|
numberplus = builtin "Number.+"
|
||||||
remotepure = builtin "Remote.pure"
|
remotepure = builtin "Remote.pure"
|
||||||
remoteMap = lam' ["f"] (builtin "Remote.bind" `app` (derived' sampleHash64 `app` remotepure `app` var' "f"))
|
remoteMap = lam' ["f"] (builtin "Remote.bind" `app` (derived' sampleHash64 `app` remotepure `app` var' "f"))
|
||||||
onenone = var' "1+1"
|
onenone = var' "1+1"
|
||||||
|
@ -35,7 +35,7 @@ instance Show StrongEq where show (StrongEq t) = show t
|
|||||||
|
|
||||||
env :: TNode -> TEnv IO
|
env :: TNode -> TEnv IO
|
||||||
env node r = do
|
env node r = do
|
||||||
(node, _) <- Note.lift node
|
(node, _, _) <- Note.lift node
|
||||||
Node.typeAt node (E.ref r) mempty
|
Node.typeAt node (E.ref r) mempty
|
||||||
|
|
||||||
localsAt :: TNode -> Path -> TTerm -> IO [(V, Type V)]
|
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 :: TNode -> Path -> TTerm -> TType -> Assertion
|
||||||
synthesizesAt node path e t = Note.run $ do
|
synthesizesAt node path e t = Note.run $ do
|
||||||
(node, _) <- Note.lift node
|
(node, _, _) <- Note.lift node
|
||||||
t2 <- Node.typeAt node e path
|
t2 <- Node.typeAt node e path
|
||||||
_ <- Note.fromEither (Typechecker.subtype t2 t)
|
_ <- Note.fromEither (Typechecker.subtype t2 t)
|
||||||
_ <- Note.fromEither (Typechecker.subtype t t2)
|
_ <- Note.fromEither (Typechecker.subtype t t2)
|
||||||
@ -80,7 +80,7 @@ synthesizesAndChecks node e t =
|
|||||||
|
|
||||||
--singleTest = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typechecker"
|
--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
|
-- testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
|
||||||
-- (unsafeParseTerm tms)
|
-- (unsafeParseTerm tms)
|
||||||
-- (unsafeParseType "forall x. x -> Number")
|
-- (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
|
, testCase "synthesize/check (x y -> y)" $ synthesizesAndChecks node
|
||||||
(unsafeParseTerm "x y -> y")
|
(unsafeParseTerm "x y -> y")
|
||||||
(unsafeParseType "forall a b. a -> b -> b")
|
(unsafeParseType "forall a b. a -> b -> b")
|
||||||
, testCase "synthesize/check (let f = (+) in f 1)" $ synthesizesAndChecks node
|
, testCase "synthesize/check (let f = (+); f 1;;)" $ synthesizesAndChecks node
|
||||||
(unsafeParseTerm "let f = (+) in f 1")
|
(unsafeParseTerm "let f = (+); f 1;;")
|
||||||
(T.lit T.Number --> T.lit T.Number)
|
(T.lit T.Number --> T.lit T.Number)
|
||||||
, testCase "synthesize/check (let blank x = _ in blank 1)" $ synthesizesAndChecks node
|
, testCase "synthesize/check (let blank x = _; blank 1;;)" $ synthesizesAndChecks node
|
||||||
(unsafeParseTerm "let blank x = _ in blank 1")
|
(unsafeParseTerm "let blank x = _; blank 1;;")
|
||||||
(forall' ["a"] $ T.v' "a")
|
(forall' ["a"] $ T.v' "a")
|
||||||
, testCase "synthesize/check Term.fix" $ synthesizesAndChecks node
|
, 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")
|
(forall' ["a"] $ (T.v' "a" --> T.v' "a") --> T.v' "a")
|
||||||
, testCase "synthesize/check Term.pingpong1" $ synthesizesAndChecks node
|
, testCase "synthesize/check Term.pingpong1" $ synthesizesAndChecks node
|
||||||
Term.pingpong1
|
Term.pingpong1
|
||||||
@ -137,15 +137,15 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
|
|||||||
, testTerm "[1, 2, 1 + 1]" $ \tms ->
|
, testTerm "[1, 2, 1 + 1]" $ \tms ->
|
||||||
testCase ("synthesize/checkAt "++tms++"@[Index 2]") $ synthesizesAndChecksAt node
|
testCase ("synthesize/checkAt "++tms++"@[Index 2]") $ synthesizesAndChecksAt node
|
||||||
[Paths.Index 2] (unsafeParseTerm tms) (T.lit T.Number)
|
[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
|
testCase ("synthesize/checkAt ("++tms++")@[Binding 0,Body]") $ synthesizesAndChecksAt node
|
||||||
[Paths.Binding 0, Paths.Body] (unsafeParseTerm tms) unconstrained
|
[Paths.Binding 0, Paths.Body] (unsafeParseTerm tms) unconstrained
|
||||||
-- fails
|
-- 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
|
testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
|
||||||
(unsafeParseTerm tms)
|
(unsafeParseTerm tms)
|
||||||
(unsafeParseType "forall x. x -> Number")
|
(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
|
testCase ("synthesize/check ("++tms++")") $ synthesizesAndChecks node
|
||||||
(unsafeParseTerm tms) (unsafeParseType "forall x. x -> Number")
|
(unsafeParseTerm tms) (unsafeParseType "forall x. x -> Number")
|
||||||
, testTerm "f x y -> (x y -> y) f _ + _" $ \tms ->
|
, testTerm "f x y -> (x y -> y) f _ + _" $ \tms ->
|
||||||
@ -153,14 +153,14 @@ tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typecheck
|
|||||||
synthesizesAndChecks node
|
synthesizesAndChecks node
|
||||||
(unsafeParseTerm tms)
|
(unsafeParseTerm tms)
|
||||||
(unsafeParseType "forall a b c. a -> b -> c -> Number")
|
(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) $
|
testCase ("higher rank checking: " ++ tms) $
|
||||||
let
|
let
|
||||||
t = unsafeParseType "(forall a . a -> a) -> Number"
|
t = unsafeParseType "(forall a . a -> a) -> Number"
|
||||||
tm = unsafeParseTerm tms
|
tm = unsafeParseTerm tms
|
||||||
in synthesizesAndChecks node tm t
|
in synthesizesAndChecks node tm t
|
||||||
-- Let generalization not implemented yet; this test fails
|
-- 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
|
-- let
|
||||||
-- tm = E.let1'
|
-- tm = E.let1'
|
||||||
-- [ ("id", E.lam' ["a"] (E.var' "a") `E.ann` T.forall' ["a"] (T.v' "a")),
|
-- [ ("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
|
[(_,xt), (_,yt)] <- localsAt node [Paths.Body, Paths.Body, Paths.Fn, Paths.Arg] tm
|
||||||
assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
|
assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
|
||||||
assertEqual "yt unconstrainted" unconstrained (T.generalize yt)
|
assertEqual "yt unconstrainted" unconstrained (T.generalize yt)
|
||||||
, testTerm "let x = _ in _" $ \tms ->
|
, testTerm "let x = _; _;;" $ \tms ->
|
||||||
testCase ("locals ("++tms++")") $ do
|
testCase ("locals ("++tms++")") $ do
|
||||||
let tm = unsafeParseTerm tms
|
let tm = unsafeParseTerm tms
|
||||||
[(_,xt)] <- localsAt node [Paths.Body] tm
|
[(_,xt)] <- localsAt node [Paths.Body] tm
|
||||||
[] <- localsAt node [Paths.Binding 0, Paths.Body] tm
|
[] <- localsAt node [Paths.Binding 0, Paths.Body] tm
|
||||||
assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
|
assertEqual "xt unconstrainted" unconstrained (T.generalize xt)
|
||||||
, testTerm "let x = _; y = _ in _" $ \tms ->
|
, testTerm "let x = _; y = _; _;;" $ \tms ->
|
||||||
testCase ("locals ("++tms++")@[Body,Body]") $ do
|
testCase ("locals ("++tms++")@[Body,Body]") $ do
|
||||||
let tm = unsafeParseTerm tms
|
let tm = unsafeParseTerm tms
|
||||||
[(_,xt), (_,yt)] <- localsAt node [Paths.Body, Paths.Body] tm
|
[(_,xt), (_,yt)] <- localsAt node [Paths.Body, Paths.Body] tm
|
||||||
assertEqual "xt unconstrained" unconstrained (T.generalize xt)
|
assertEqual "xt unconstrained" unconstrained (T.generalize xt)
|
||||||
assertEqual "yt unconstrained" unconstrained (T.generalize yt)
|
assertEqual "yt unconstrained" unconstrained (T.generalize yt)
|
||||||
, testTerm "let x = _; y = _ in _" $ \tms ->
|
, testTerm "let x = _; y = _; _;;" $ \tms ->
|
||||||
-- testTerm "let x = 42; y = _ in _" $ \tms ->
|
-- testTerm "let x = 42; y = _; _" $ \tms ->
|
||||||
-- testTerm "let x = 42; y = 43 in _" $ \tms ->
|
-- testTerm "let x = 42; y = 43; _" $ \tms ->
|
||||||
-- testTerm "let x = 42; y = 43 in 4224" $ \tms ->
|
-- testTerm "let x = 42; y = 43; 4224" $ \tms ->
|
||||||
testCase ("locals ("++tms++")@[Body,Binding 0,Body]") $ do
|
testCase ("locals ("++tms++")@[Body,Binding 0,Body]") $ do
|
||||||
let tm = unsafeParseTerm tms
|
let tm = unsafeParseTerm tms
|
||||||
[(_,xt)] <- localsAt node [Paths.Body, Paths.Binding 0, Paths.Body] tm
|
[(_,xt)] <- localsAt node [Paths.Body, Paths.Binding 0, Paths.Body] tm
|
||||||
|
@ -15,30 +15,25 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
|
|||||||
tests =
|
tests =
|
||||||
[
|
[
|
||||||
-- simple case, no minimization done
|
-- simple case, no minimization done
|
||||||
t "let id x = x; g = id 42; y = id id g in y"
|
t "let id x = x; g = id 42; y = id id g; y;;"
|
||||||
"let id x = x; g = id 42; y = id id g in y"
|
"let id x = x; g = id 42; y = id id g; y;;"
|
||||||
-- check that we get let generalization
|
-- check that we get let generalization
|
||||||
, t "let rec id x = x; g = id 42; y = id id g in y"
|
, t "let rec id x = x; g = id 42; y = id id g; y;;"
|
||||||
"let id x = x; g = id 42; y = id id g in y"
|
"let id x = x; g = id 42; y = id id g; y;;"
|
||||||
-- check that we preserve order of components as much as possible
|
-- check that we preserve order of components as much as possible
|
||||||
, t "let rec id2 x = x; id1 x = x; id3 x = x in id3"
|
, t "let rec id2 x = x; id1 x = x; id3 x = x; id3;;"
|
||||||
"let id2 x = x; id1 x = x; id3 x = x in id3"
|
"let id2 x = x; id1 x = x; id3 x = x; id3;;"
|
||||||
-- check that we reorder according to dependencies
|
-- check that we reorder according to dependencies
|
||||||
, t "let rec g = id 42; y = id id g; id x = x in y"
|
, t "let rec g = id 42; y = id id g; id x = x; y;;"
|
||||||
"let id x = x; g = id 42; y = id id g in y"
|
"let id x = x; g = id 42; y = id id g; y;;"
|
||||||
-- insane example, checks for: generalization, reordering,
|
-- insane example, checks for: generalization, reordering,
|
||||||
-- preservation of order when possible
|
-- preservation of order when possible
|
||||||
, t "let rec g = id 42; y = id id g; ping x = pong x; pong x = id (ping x); id x = x in y"
|
, t "let rec g = id 42; y = id id g; ping x = pong x; pong x = id (ping x); id x = x; y;;"
|
||||||
"let id x = x; g = id 42; y = id id g in (let rec ping x = pong x; pong x = id (ping x) in y)"
|
"let id x = x; g = id 42; y = id id g ; (let rec ping x = pong x; pong x = id (ping x) ; y;;);;"
|
||||||
]
|
]
|
||||||
t before after = testCase (before ++ " ⟹ " ++ after) $ do
|
t before after = testCase (before ++ " ⟹ " ++ after) $ do
|
||||||
(node, _) <- node
|
(node, _, _) <- node
|
||||||
let term = unsafeParseTerm before
|
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
|
let after' = Components.minimize' term
|
||||||
_ <- Note.run $ Node.typeAt node after' []
|
_ <- Note.run $ Node.typeAt node after' []
|
||||||
assertEqual "comparing results" (unsafeParseTerm after) after'
|
assertEqual "comparing results" (unsafeParseTerm after) after'
|
||||||
|
@ -111,7 +111,9 @@ test-suite tests
|
|||||||
other-modules:
|
other-modules:
|
||||||
build-depends:
|
build-depends:
|
||||||
base,
|
base,
|
||||||
|
bytestring,
|
||||||
containers,
|
containers,
|
||||||
|
filepath,
|
||||||
tasty,
|
tasty,
|
||||||
tasty-hunit,
|
tasty-hunit,
|
||||||
tasty-smallcheck,
|
tasty-smallcheck,
|
||||||
|
@ -13,3 +13,8 @@ extra-deps:
|
|||||||
- cacophony-0.7.0
|
- cacophony-0.7.0
|
||||||
- cryptonite-0.17
|
- cryptonite-0.17
|
||||||
- unagi-chan-0.4.0.0
|
- 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
268
unison-src/base.u
Normal 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
11
unison-src/dindex-main.u
Normal 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
98
unison-src/dindex.u
Normal 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
119
unison-src/extra.u
Normal 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
5
unison-src/fork.u
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
do Remote
|
||||||
|
Remote.fork <| Remote.sleep (Duration.seconds 10);
|
||||||
|
Remote.fork <| Remote.sleep (Duration.seconds 10);
|
||||||
|
pure 23;;
|
||||||
|
|
@ -1,4 +1,4 @@
|
|||||||
-- run from unison root directory
|
-- 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
|
-- 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"
|
@ -1,15 +1,15 @@
|
|||||||
-- run from unison root directory
|
-- 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
|
-- 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;
|
n1 := Remote.spawn;
|
||||||
n2 := Remote.spawn;
|
n2 := Remote.spawn;
|
||||||
ind := Remote {
|
ind := do Remote
|
||||||
Remote.transfer n1;
|
Remote.transfer n1;
|
||||||
ind := Index.empty;
|
ind := Index.empty;
|
||||||
Index.insert "Unison" "Rulez!!!1" ind;
|
Index.insert "Alice" "Jones" ind;
|
||||||
pure ind;
|
Index.insert "Bob" "Smith" ind;
|
||||||
};
|
pure ind;;
|
||||||
|
;
|
||||||
Remote.transfer n2;
|
Remote.transfer n2;
|
||||||
Index.lookup "Unison" ind;
|
Index.lookup "Alice" ind;;
|
||||||
}
|
|
13
unison-src/indexed-traversal.u
Normal file
13
unison-src/indexed-traversal.u
Normal 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
17
unison-src/pingpong.u
Normal 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
6
unison-src/race.u
Normal 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
8
unison-src/receive-async.u
Normal 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
94
unison-src/searchengine.u
Normal 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;;
|
||||||
|
;;
|
Loading…
Reference in New Issue
Block a user