some std lib naming tweaks, modified type parser to allow dots in identifiers

This commit is contained in:
Paul Chiusano 2016-08-23 12:58:43 -04:00
parent fc976fcfaa
commit 968733efb3
13 changed files with 149 additions and 96 deletions

View File

@ -32,10 +32,10 @@ index :: Remote.Node -> Term.Term V -> Term.Term V
index node h = Term.ref (R.Builtin "Index") `Term.apps` [Term.node node, h]
linkT :: Ord v => Type v
linkT = Type.ref (R.Builtin "Link")
linkT = Type.ref (R.Builtin "Html.Link")
link :: Term.Term V -> Term.Term V -> Term.Term V
link href description = Term.ref (R.Builtin "Link") `Term.app` href `Term.app` description
link href description = Term.ref (R.Builtin "Html.Link") `Term.app` href `Term.app` description
linkToTerm :: Html.Link -> Term.Term V
linkToTerm (Html.Link href description) = link (Term.lit $ Term.Text href)
@ -46,7 +46,7 @@ pattern Index' node s <-
(Term.Text' s)
pattern Link' href description <-
Term.App' (Term.App' (Term.Ref' (R.Builtin "Link"))
Term.App' (Term.App' (Term.Ref' (R.Builtin "Html.Link"))
(Term.Text' href))
(Term.Text' description)
@ -61,15 +61,15 @@ makeAPI blockStore crypto = do
resourcePool <- RP.make 3 10 (Index.loadEncrypted blockStore crypto) Index.flush
pure (\whnf -> map (\(r, o, t, m) -> Builtin r o t m)
[ -- Index
let r = R.Builtin "Index.empty!"
let r = R.Builtin "Index.empty#"
op [self] = do
ident <- Note.lift nextID
Term.Distributed' (Term.Node self) <- whnf self
pure . index self . Term.lit . Term.Text . Index.idToText $ ident
op _ = fail "Index.empty! unpossible"
op _ = fail "Index.empty# unpossible"
type' = unsafeParseType "forall k v. Node -> Index k v"
in (r, Just (I.Primop 1 op), type', prefix "Index.empty!")
, let r = R.Builtin "Index.lookup!"
in (r, Just (I.Primop 1 op), type', prefix "Index.empty#")
, let r = R.Builtin "Index.lookup#"
op [key, indexToken] = inject g indexToken key where
inject g indexToken key = do
i <- whnf indexToken
@ -81,26 +81,26 @@ makeAPI blockStore crypto = do
flip finally cleanup $ do
result <- atomically $ Index.lookup (SAH.hash' k) db
case result >>= (pure . SAH.deserializeTermFromBytes . snd) of
Just (Left s) -> fail ("Index.lookup! could not deserialize: " ++ s)
Just (Left s) -> fail ("Index.lookup# could not deserialize: " ++ s)
Just (Right t) -> pure $ some t
Nothing -> pure none
pure val
g s k = pure $ Term.ref r `Term.app` s `Term.app` k
op _ = fail "Index.lookup! unpossible"
op _ = fail "Index.lookup# unpossible"
type' = unsafeParseType "forall k v. k -> Index k v -> Optional v"
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup!")
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup#")
, let r = R.Builtin "Index.lookup"
op [key, index] = do
Index' node tok <- whnf index
pure $
Term.builtin "Remote.map" `Term.apps` [
Term.builtin "Index.lookup!" `Term.app` key,
Term.builtin "Index.lookup#" `Term.app` key,
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
]
op _ = fail "Index.lookup unpossible"
type' = unsafeParseType "forall k v. k -> Index k v -> Remote (Optional v)"
in (r, Just (I.Primop 2 op), type', prefix "Index.lookup")
, let r = R.Builtin "Index.insert!"
, let r = R.Builtin "Index.insert#"
op [k, v, index] = inject g k v index where
inject g k v index = do
k' <- whnf k
@ -115,15 +115,15 @@ makeAPI blockStore crypto = do
>>= atomically
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.insert# unpossible"
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 "Index.insert#")
, let r = R.Builtin "Index.insert"
op [key, value, index] = do
Index' node tok <- whnf index
pure $
Term.builtin "Remote.map" `Term.apps` [
Term.builtin "Index.insert!" `Term.apps` [key,value],
Term.builtin "Index.insert#" `Term.apps` [key,value],
Term.builtin "Remote.at" `Term.apps` [Term.node node, Term.text tok]
]
op _ = fail "Index.insert unpossible"
@ -139,7 +139,7 @@ makeAPI blockStore crypto = do
$ Html.getLinks h
x -> Term.ref r `Term.app` x
op _ = fail "Html.getLinks unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Link", prefix "getLinks")
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Vector Html.Link", prefix "Html.getLinks")
, let r = R.Builtin "Html.getHref"
op [link] = do
link' <- whnf link
@ -147,7 +147,7 @@ makeAPI blockStore crypto = do
Link' href _ -> Term.lit (Term.Text href)
x -> Term.ref r `Term.app` x
op _ = fail "Html.getHref unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getHref")
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.getHref")
, let r = R.Builtin "Html.getDescription"
op [link] = do
link' <- whnf link
@ -155,10 +155,10 @@ makeAPI blockStore crypto = do
Link' _ d -> Term.lit (Term.Text d)
x -> Term.ref r `Term.app` x
op _ = fail "Html.getDescription unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Link -> Text", prefix "getDescription")
in (r, Just (I.Primop 1 op), unsafeParseType "Html.Link -> Text", prefix "Html.getDescription")
-- Http
, let r = R.Builtin "Http.getURL!"
, let r = R.Builtin "Http.getUrl#"
op [url] = do
url <- whnf url
case url of
@ -168,23 +168,23 @@ makeAPI blockStore crypto = do
Right x -> right $ Term.text x
Left x -> left . Term.text . Text.pack $ show x
x -> pure $ Term.ref r `Term.app` x
op _ = fail "Http.getURL! unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.getURL!")
, let r = R.Builtin "Http.getURL"
op _ = fail "Http.getUrl# unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Either Text Text", prefix "Http.getUrl#")
, let r = R.Builtin "Http.getUrl"
op [url] = pure $ Term.builtin "Remote.pure" `Term.app`
(Term.builtin "Http.getURL!" `Term.app` url)
op _ = fail "Http.getURL unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "Http.getURL")
(Term.builtin "Http.getUrl#" `Term.app` url)
op _ = fail "Http.getUrl unpossible"
in (r, Just (I.Primop 1 op), unsafeParseType "Text -> Remote (Either Text Text)", prefix "Http.getUrl")
-- Hashing
-- add erase, comparison functions
, let r = R.Builtin "hash!"
, let r = R.Builtin "hash#"
op [e] = do
e <- whnf e
pure $ Term.builtin "Hash" `Term.app` (Term.ref $ SAH.hash e)
op _ = fail "hash"
t = "forall a . a -> Hash a"
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "hash!")
in (r, Just (I.Primop 1 op), unsafeParseType t, prefix "hash#")
, let r = R.Builtin "Hash.erase"
op [e] = pure e
op _ = fail "hash"

View File

@ -15,7 +15,6 @@ import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Unison.Config as Config
import qualified Unison.Cryptography as C
import qualified Unison.Eval.Interpreter as I
import qualified Unison.Node as Node
import qualified Unison.Node.BasicNode as BasicNode
import qualified Unison.Node.Builtin as Builtin

View File

@ -39,10 +39,10 @@ tests = testGroup "html"
]
-- evaluateTerms :: [(Path, e)] -> Noted m [(Path,e,e)],
unisonEvaluate :: TestNode -> Assertion
unisonEvaluate testNode = do
unisonEvaluate :: (TestNode, String -> TermV) -> Assertion
unisonEvaluate (testNode, parse) = do
let inputPath = [P.Fn]
getLinksTerm = unsafeParseTerm $ "getLinks \"" ++ testHTML2 ++ "\""
getLinksTerm = parse $ "Html.getLinks \"" ++ testHTML2 ++ "\""
linkTerm = EB.link (Term.text "link.html") (Term.text "description")
getLink = Term.ref (R.Builtin "Html.getHref") `Term.app` linkTerm
getDescription = Term.ref (R.Builtin "Html.getDescription") `Term.app` linkTerm
@ -64,8 +64,13 @@ unisonEvaluate testNode = do
, "description match ", show (description == desiredDescription)
]
nodeTests :: TestNode -> TestTree
nodeTests :: (TestNode, String -> TermV) -> TestTree
nodeTests testNode = testGroup "html"
[ testCase "numlinks" numlinks
, testCase "unisonEvaluate" (unisonEvaluate testNode)
]
main :: IO ()
main = do
testNode <- makeTestNode
defaultMain (nodeTests testNode)

View File

@ -2,6 +2,7 @@
module Unison.Test.NodeUtil where
import Control.Applicative
import Unison.Hash (Hash)
import Unison.Node (Node)
import Unison.Reference (Reference)
@ -10,13 +11,20 @@ import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Var (Var)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified System.FilePath as FP
import qualified Unison.ABT as ABT
import qualified Unison.BlockStore.MemBlockStore as MBS
import qualified Unison.Cryptography as C
import qualified Unison.Hash as Hash
import qualified Unison.Node as Node
import qualified Unison.Node.BasicNode as BasicNode
import qualified Unison.Node.Builtin as Builtin
import qualified Unison.Node.FileStore as FS
import qualified Unison.Node.UnisonBlockStore as UBS
import qualified Unison.Note as Note
import qualified Unison.Parsers as Parsers
import qualified Unison.Reference as R
import qualified Unison.Reference as Reference
import qualified Unison.Runtime.ExtraBuiltins as EB
@ -25,6 +33,7 @@ import qualified Unison.View as View
type DFO = View.DFO
type V = Symbol DFO
type TermV = Term V
type TestNode = Node IO V R.Reference (Type V) (Term V)
hash :: Var v => Term.Term v -> Reference
@ -34,11 +43,31 @@ hash t = Reference.Derived (ABT.hash t)
makeRandomAddress :: C.Cryptography k syk sk skp s h c -> IO Address
makeRandomAddress crypt = Address <$> C.randomBytes crypt 64
makeTestNode :: IO TestNode
loadDeclarations :: 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 <- Text.IO.readFile path <|> Text.IO.readFile (".." `FP.combine` path)
let str = Text.unpack txt
_ <- Note.run $ Node.declare' Term.ref str node
putStrLn $ "loaded file: " ++ path
makeTestNode :: IO (TestNode, String -> Term V)
makeTestNode = do
let crypto = C.noop "dummypublickey"
putStrLn "creating block store..."
blockStore <- MBS.make' (makeRandomAddress crypto) makeAddress
putStrLn "created block store, creating Node store..."
store' <- UBS.make blockStore
keyValueOps <- EB.makeAPI blockStore crypto
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, keyValueOps whnf]
BasicNode.make hash store' makeBuiltins
-- store' <- FS.make "blockstore.file"
putStrLn "created Node store..., building extra builtins"
extraBuiltins <- EB.makeAPI blockStore crypto
putStrLn "extra builtins created"
let makeBuiltins whnf = concat [Builtin.makeBuiltins whnf, extraBuiltins whnf]
node <- BasicNode.make hash store' makeBuiltins
putStrLn "Node created"
loadDeclarations "unison-src/base.u" node
loadDeclarations "unison-src/extra.u" node
builtins <- Note.run $ Node.allTermsByVarName Term.ref node
let parse = Parsers.bindBuiltins builtins [] . Parsers.unsafeParseTerm
pure (node, parse)

View File

@ -95,6 +95,20 @@ identifier' charTests stringTests = do
guard (all ($ i) stringTests)
pure i
-- a wordyId isn't all digits, and isn't all symbols
wordyId :: [String] -> Parser String
wordyId keywords = token $ f <$> sepBy1 dot id
where
dot = char '.'
id = identifier [any (not . Char.isDigit), any Char.isAlphaNum, (`notElem` keywords)]
f segs = intercalate "." segs
-- a symbolyId is all symbols
symbolyId :: [String] -> Parser String
symbolyId keywords = token $ identifier'
[notReservedChar, not . Char.isSpace, \c -> Char.isSymbol c || Char.isPunctuation c]
[(`notElem` keywords)]
token :: Parser a -> Parser a
token p = p <* ignored

View File

@ -78,6 +78,7 @@ termBuiltins = (Var.named *** Term.ref) <$> (
, Builtin "False"
, Builtin "()"
, Alias "unit" "()"
, Alias "Unit" "()"
, Alias "Some" "Optional.Some"
, Alias "None" "Optional.None"
, Alias "Left" "Either.Left"
@ -124,7 +125,7 @@ typeBuiltins = (Var.named *** Type.lit) <$>
-- kv store
, builtin "Index"
-- html
, builtin "Link"
, builtin "Html.Link"
-- distributed
, builtin "Channel"
, builtin "Future"

View File

@ -76,7 +76,7 @@ tupleOrParenthesized rec =
-- y = 11;
-- pure (f x);;
effectBlock :: forall v . Var v => Parser (Term v)
effectBlock = (token (string "do") *> wordyId) >>= go where
effectBlock = (token (string "do") *> wordyId keywords) >>= go where
go name = do
bindings <- some $ asum [Right <$> binding, Left <$> action] <* semicolon
semicolon
@ -96,7 +96,7 @@ effectBlock = (token (string "do") *> wordyId) >>= go where
interpretPure = ABT.subst (ABT.v' "pure") qualifiedPure
binding :: Parser (v, Term v)
binding = scope "binding" $ do
lhs <- ABT.v' . Text.pack <$> token wordyId
lhs <- ABT.v' . Text.pack <$> token (wordyId keywords)
eff <- token $ (True <$ string ":=") <|> (False <$ string "=")
rhs <- term
let rhs' = if eff then interpretPure rhs
@ -181,36 +181,22 @@ bindingEqBody p = eq *> body
eq = token (char '=')
body = lineErrorUnless "parse error in body of binding" p
-- a wordyId isn't all digits, and isn't all symbols
wordyId :: Parser String
wordyId = token $ f <$> id <*> optional ((:) <$> dot <*> wordyId)
where
dot = char '.'
id = identifier [any (not.isDigit), any isAlphaNum, (`notElem` keywords)]
f id rest = maybe id (id++) rest
-- a symbolyId is all symbols
symbolyId :: Parser String
symbolyId = token $ identifier'
[notReservedChar, not . isSpace, \c -> isSymbol c || isPunctuation c]
[(`notElem` keywords)]
infixVar :: Var v => Parser v
infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId)
infixVar = (Var.named . Text.pack) <$> (backticked <|> symbolyId keywords)
where
backticked = char '`' *> wordyId <* token (char '`')
backticked = char '`' *> wordyId keywords <* token (char '`')
prefixVar :: Var v => Parser v
prefixVar = (Var.named . Text.pack) <$> prefixOp
where
prefixOp :: Parser String
prefixOp = wordyId <|> (char '(' *> symbolyId <* token (char ')')) -- no whitespace w/in parens
prefixOp = wordyId keywords <|> (char '(' *> symbolyId keywords <* token (char ')')) -- no whitespace w/in parens
prefixTerm :: Var v => Parser (Term v)
prefixTerm = Term.var <$> prefixVar
keywords :: Set String
keywords = Set.fromList ["do", "let", "rec", "in", "->", ":", "=", "where"]
keywords :: [String]
keywords = ["do", "let", "rec", "in", "->", ":", "=", "where"]
lam :: Var v => Parser (Term v) -> Parser (Term v)
lam p = Term.lam'' <$> vars <* arrow <*> body

View File

@ -2,7 +2,7 @@
module Unison.TypeParser where
import Control.Monad
import Control.Applicative ((<|>), some, many)
import Data.Char (isUpper, isLower, isAlpha)
import Data.Foldable (asum)
@ -55,10 +55,19 @@ forall rec = do
pure $ Type.forall' (fmap Text.pack vars) t
varName :: Parser String
varName = identifier [isLower.head, all isAlpha]
varName = do
name <- wordyId keywords
guard (isLower . head $ name)
pure name
typeName :: Parser String
typeName = identifier [isUpper.head]
typeName = do
name <- wordyId keywords
guard (isUpper . head $ name)
pure name
keywords :: [String]
keywords = ["forall", ""]
-- qualifiedTypeName :: Parser String
-- qualifiedTypeName = f <$> typeName <*> optional more
@ -68,9 +77,9 @@ typeName = identifier [isUpper.head]
-- more = (:) <$> char '.' <*> qualifiedTypeName
literal :: Var v => Parser (Type v)
literal =
token $ asum [ Type.lit Type.Number <$ string "Number"
, Type.lit Type.Text <$ string "Text"
, Type.lit Type.Vector <$ string "Vector"
, (Type.v' . Text.pack) <$> typeName
]
literal = scope "literal" . token $
asum [ Type.lit Type.Number <$ string "Number"
, Type.lit Type.Text <$ string "Text"
, Type.lit Type.Vector <$ string "Vector"
, (Type.v' . Text.pack) <$> typeName
]

View File

@ -16,6 +16,12 @@ import qualified Unison.Type as T
-- import Test.Tasty.SmallCheck as SC
-- import Test.Tasty.QuickCheck as QC
parse' :: String -> TestTree
parse' s = testCase ("`" ++ s ++ "`") $
case parseTerm s of
Fail e _ -> assertFailure $ "parse failure " ++ intercalate "\n" e
Succeed a _ _ -> pure ()
parse :: (String, Term (Symbol DFO)) -> TestTree
parse (s, expected) =
testCase ("`" ++ s ++ "`") $
@ -31,13 +37,17 @@ parseFail (s, reason) =
Succeed _ n _ -> n == length s;
tests :: TestTree
tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> shouldFail)
tests = testGroup "TermParser" $ (parse <$> shouldPass)
++ (parse' <$> shouldParse)
++ (parseFail <$> shouldFail)
where
shouldFail =
[ ("+", "operator needs to be enclosed in parens or between arguments")
, ("#V-fXHD3-N0E", "invalid base64url")
, ("#V-f/XHD3-N0E", "invalid base64url")
]
shouldParse =
[ "do Remote n1 := Remote.spawn; n2 := Remote.spawn; let rec x = 10; Remote.pure 42;;; ;" ]
shouldPass =
[ ("1", one)
, ("[1,1]", vector [one, one])
@ -88,7 +98,7 @@ tests = testGroup "TermParser" $ (parse <$> shouldPass) ++ (parseFail <$> should
, ("let rec fix f = f (fix f); fix;;", fix) -- fix
, ("1 + 2 + 3", num 1 `plus'` num 2 `plus'` num 3)
, ("[1, 2, 1 + 1]", vector [num 1, num 2, num 1 `plus'` num 1])
, ("(id -> let x = id 42; y = id \"hi\"; 43;;) : (forall a.a) -> Number", lam' ["id"] (let1'
, ("(id -> let x = id 42; y = id \"hi\"; 43;;) : (forall a . a) -> Number", lam' ["id"] (let1'
[ ("x", var' "id" `app` num 42),
("y", var' "id" `app` text "hi")
] (num 43)) `ann` (T.forall' ["a"] (T.v' "a") `T.arrow` T.lit T.Number))

View File

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

View File

@ -1,22 +1,32 @@
identity : ∀ a . a -> a;
identity a = a;
const x y = x;
then : ∀ a b c . (a -> b) -> (b -> c) -> a -> c;
then f1 f2 x = f2 (f1 x);
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 `then` first;
3rd = rest `then` (rest `then` first);
4th = rest `then` (rest `then` (rest `then` first));
5th = rest `then` (rest `then` (rest `then` (rest `then` first)));
Remote.transfer : Node -> Remote Unit;
Remote.transfer node = Remote.at node unit;
Remote.map : ∀ a b . (a -> b) -> Remote a -> Remote b;
Remote.map f = Remote.bind (f `then` Remote.pure);
Remote =
( Remote.pure : ∀ a . a -> Remote a
, Remote.bind : ∀ a b . (a -> Remote b) -> Remote a -> Remote b);
Vector.replicate : ∀ a . Number -> a -> Vector a;
Vector.replicate n a = Vector.map (const a) (Vector.range 0 n);
@ -77,16 +87,3 @@ Either.bind = Either.fold Left;
Either.swap : ∀ a b . Either a b -> Either b a;
Either.swap e = Either.fold Right Left e;
const x y = x;
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 `then` first;
3rd = rest `then` (rest `then` first);
4th = rest `then` (rest `then` (rest `then` first));
5th = rest `then` (rest `then` (rest `then` (rest `then` first)));

View File

@ -1,4 +1,4 @@
Index.empty : ∀ k v . Remote (Index k v);
Index.empty =
Remote.map Index.unsafeEmpty Remote.here;
Remote.map Index.empty# Remote.here;

View File

@ -1,14 +1,17 @@
-- 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
-- curl -H "Content-Type: text/plain; charset=UTF-8" --data-binary @unison-src/pingpong.u http://localhost:8081/compute/root
Remote {
do Remote
n1 := Remote.spawn;
n2 := Remote.spawn;
let rec
ping i = Remote {
ping i = do 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;
}
if (i >= 5) (pure i) (pong i);;
;
pong i = do Remote
i := Remote.at n1 (i + 1);
ping i;;
;
ping 0;;
;;