unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 02:25:39 +03:00
Code Issues Projects Releases Wiki Activity

convert to strict interpreter, add if-then-else syntax

Browse Source
This commit is contained in:
Paul Chiusano 2016-09-26 17:59:13 -04:00
parent 328939809c
commit dbb2cd0de2
7 changed files with 70 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,6 +9,7 @@ import Unison.Eval
import Unison.Term (Term)
import Unison.Var (Var)
import qualified Data.Map as M
import qualified Data.Text as Text
import qualified Unison.ABT as ABT
import qualified Unison.Reference as R
import qualified Unison.Term as E
@ -30,6 +31,14 @@ eval env = Eval whnf step
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 -> pure Nothing
Just op | length args >= arity op ->
@ -64,11 +73,20 @@ eval env = Eval whnf step
Just op | arity op == 0 -> call op []
_ -> pure e
E.Ann' e _ -> whnf resolveRef e
E.Apps' E.If' (cond:t:f:tl) -> do
cond <- whnf resolveRef cond
case cond of
E.Builtin' b | Text.head b == 'F' -> whnf resolveRef f >>= \f -> whnf resolveRef (f `E.apps` tl)
| otherwise -> whnf resolveRef t >>= \t -> whnf resolveRef (t `E.apps` tl)
_ -> pure e
E.App' f x -> do
f' <- E.link resolveRef f
x <- whnf resolveRef x
e' <- reduce resolveRef f' [x]
maybe (pure e) (whnf resolveRef) e'
E.Let1' binding body -> whnf resolveRef (ABT.bind body binding)
maybe (pure $ f' `E.app` x) (whnf resolveRef) e'
E.Let1' binding body -> do
binding <- whnf resolveRef binding
whnf resolveRef (ABT.bind body binding)
E.LetRecNamed' bs body -> whnf resolveRef (ABT.substs substs body) where
expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
expandBinding v body = ABT.substs substs' body

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

@ -136,18 +136,6 @@ makeBuiltins logger whnf =
op _ = error "unpossible"
typ = "Boolean -> Boolean"
in (r, Just (I.Primop 1 op), unsafeParseType typ, prefix "not")
, let r = R.Builtin "Boolean.if";
op [cond,t,f] = do
cond <- whnf cond
case cond of
Term.Builtin' tf -> case Text.head tf of
'T' -> whnf t
'F' -> whnf f
_ -> error "unpossible"
_ -> error "unpossible"
op _ = error "unpossible"
typ = "forall a . Boolean -> a -> a -> a"
in (r, Just (I.Primop 3 op), unsafeParseType typ, prefix "if")
-- Number
, let r = R.Builtin "Number.+"

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

@ -45,11 +45,13 @@ import qualified Unison.Remote as Remote
data Literal
= Number Double
| Text Text
| If
deriving (Eq,Ord,Generic)
instance Hashable Literal where
tokens (Number d) = [Hashable.Tag 0, Hashable.Double d]
tokens (Text txt) = [Hashable.Tag 1, Hashable.Text txt]
tokens If = [Hashable.Tag 2]
-- | Base functor for terms in the Unison language
data F v a
@ -119,6 +121,7 @@ pattern Var' v <- ABT.Var' v
pattern Lit' l <- (ABT.out -> ABT.Tm (Lit l))
pattern Number' n <- Lit' (Number n)
pattern Text' s <- Lit' (Text s)
pattern If' <- Lit' If
pattern Blank' <- (ABT.out -> ABT.Tm Blank)
pattern Ref' r <- (ABT.out -> ABT.Tm (Ref r))
pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r)))
@ -334,6 +337,7 @@ instance (Ord v, FromJSON v) => J.FromJSON1 (F v) where parseJSON1 j = Aeson.par
instance Show Literal where
show (Text t) = show t
show If = "if"
show (Number n) = case floor n of
m | fromIntegral m == n -> show (m :: Int)
_ -> show n

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

@ -42,7 +42,7 @@ term2 :: Var v => Parser (S v) (Term v)
term2 = let_ term3 <|> term3
term3 :: Var v => Parser (S v) (Term v)
term3 = infixApp term4 <|> term4
term3 = ifthen <|> infixApp term4 <|> term4
infixApp :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
infixApp p = f <$> arg <*> some ((,) <$> infixVar <*> arg)
@ -62,6 +62,17 @@ term5 = lam term <|> effectBlock <|> termLeaf
termLeaf :: Var v => Parser (S v) (Term v)
termLeaf = asum [hashLit, prefixTerm, lit, tupleOrParenthesized term, blank, vector term]
ifthen :: Var v => Parser (S v) (Term v)
ifthen = do
_ <- token (string "if")
scope "if-then-else" . commit $ do
cond <- attempt term
_ <- token (string "then")
iftrue <- attempt term
_ <- token (string "else")
iffalse <- term
pure (Term.apps (Term.lit Term.If) [cond, iftrue, iffalse])
tupleOrParenthesized :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
tupleOrParenthesized rec =
parenthesized $ go <$> sepBy1 (token $ string ",") rec where
@ -198,7 +209,7 @@ prefixTerm :: Var v => Parser (S v) (Term v)
prefixTerm = Term.var <$> prefixVar
keywords :: [String]
keywords = ["alias", "do", "let", "rec", "in", "->", ":", "=", "where"]
keywords = ["alias", "do", "let", "rec", "in", "->", ":", "=", "where", "else", "then"]
lam :: Var v => Parser (S v) (Term v) -> Parser (S v) (Term v)
lam p = Term.lam'' <$> vars <* arrow <*> body

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

@ -477,10 +477,11 @@ annotateLetRecBindings letrec = do
pure $ (marker, body)
-- | Infer the type of a literal
synthLit :: Ord v => Term.Literal -> Type v
synthLit lit = Type.lit $ case lit of
Term.Number _ -> Type.Number
Term.Text _ -> Type.Text
synthLit :: Var v => Term.Literal -> Type v
synthLit lit = case lit of
Term.Number _ -> Type.lit Type.Number
Term.Text _ -> Type.lit Type.Text
Term.If -> Type.forall' ["a"] (Type.builtin "Boolean" --> Type.v' "a" --> Type.v' "a" --> Type.v' "a")
-- | Synthesize the type of the given term, updating the context in the process.
synthesize :: Var v => Term v -> M v (Type v)

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

@ -15,8 +15,8 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
, t "1 + 1 + 1" "3"
, t "(x -> x) 42" "42"
, t "let x = 2; y = 3 ; x + y;;" "5"
, t "if False 0 1" "1"
, t "if True 12 13" "12"
, t "if False then 0 else 1" "1"
, t "if True then 12 else 13" "12"
, t "1 >_Number 0" "True"
, t "1 ==_Number 1" "True"
, t "2 ==_Number 0" "False"
@ -40,13 +40,13 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
, t "False `and` False" "False"
, t "not False" "True"
, t "not True" "False"
, t "let rec fac n = if (n ==_Number 0) 1 (n * fac (n - 1)); fac 5;;" "120"
, t "let rec ping n = if (n >=_Number 10) n (pong (n + 1)); pong n = ping (n + 1); ping 0;;"
, t "let rec fac n = if n ==_Number 0 then 1 else n * fac (n - 1); fac 5;;" "120"
, t "let rec ping n = if n >=_Number 10 then n else pong (n + 1); pong n = ping (n + 1); ping 0;;"
"10"
, t "let id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
, t "let id : forall a . a -> a; id x = x; g = id 42; p = id \"hi\" ; g;;" "42"
, t "(let id x = x; id;; : forall a . a -> a) 42" "42"
, t "Optional.map ((+) 1) (Some 1)" "Some (1 + 1)"
, t "Optional.map ((+) 1) (Some 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"
@ -56,13 +56,13 @@ tests = withResource Common.node (\_ -> pure ()) $ \node ->
, t "2nd (1,2 + 1,3,4)" "3"
, t "identity <| (1 + 1)" "2"
, t "(1 + 1) |> identity" "2"
, t "if (\"hi\" ==_Text \"hi\") 1 2" "1"
, t "if (\"hi\" <_Text \"hiya\") 1 2" "1"
, t "if (\"hi\" <=_Text \"hiya\") 1 2" "1"
, t "if (\"hiya\" >_Text \"hi\") 1 2" "1"
, t "if (\"hiya\" >=_Text \"hi\") 1 2" "1"
, t "if (\"hi\" >=_Text \"hi\") 1 2" "1"
, t "if (\"hi\" <=_Text \"hi\") 1 2" "1"
, 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]"

32
unison-src/base.u
View File

@ -3,8 +3,8 @@ identity a = a;
const x y = x;
then : ∀ a b c . (a -> b) -> (b -> c) -> a -> c;
then f1 f2 x = f2 (f1 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;
@ -22,10 +22,10 @@ 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)));
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-first p = Pair new-first (rest p);
@ -63,10 +63,10 @@ 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)
(Vector.fold-left plus zero vs)
(let p = Vector.halve vs;
go plus zero (1st p) `plus` go plus zero (2nd p);;);
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;;
;
@ -74,13 +74,13 @@ Vector.all? : ∀ a . (a -> Boolean) -> Vector a -> Boolean;
Vector.all? f vs = Vector.fold-balanced and True (Vector.map f vs);
Vector.sort : ∀ k a . Order k -> (a -> k) -> Vector a -> Vector a;
Vector.sort ok f v = Vector.sort-keyed (f `then` Order.key ok) v;
Vector.sort 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 o identity;
Remote.map : ∀ a b . (a -> b) -> Remote a -> Remote b;
Remote.map f = Remote.bind (f `then` Remote.pure);
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
@ -148,7 +148,7 @@ 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 `then` Remote.map Vector.single) vs);
(Vector.map (f `and-then` Remote.map Vector.single) vs);
Remote.sequence : ∀ a . Vector (Remote a) -> Remote (Vector a);
Remote.sequence vs =
@ -158,7 +158,7 @@ Remote.sequence 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 `then` Remote.start timeout) vs;
futures := Remote.traverse (f `and-then` Remote.start timeout) vs;
Remote.sequence futures;;
;
@ -168,7 +168,7 @@ Remote.quorum : ∀ a b . Duration -> Number -> (a -> Remote b) -> Vector a -> R
Remote.quorum timeout n = _; -- todo
Optional.map : ∀ a b . (a -> b) -> Optional a -> Optional b;
Optional.map f = Optional.fold None (f `then` Some);
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;
@ -190,7 +190,7 @@ Optional.map2 f a b = do Optional
;
Either.map : ∀ a b c . (b -> c) -> Either a b -> Either a c;
Either.map f = Either.fold Left (f `then` Right);
Either.map f = Either.fold Left (f `and-then` Right);
Either.pure : ∀ a b . b -> Either a b;
Either.pure = Right;