mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
convert to strict interpreter, add if-then-else syntax
This commit is contained in:
parent
328939809c
commit
dbb2cd0de2
@ -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
|
||||
|
@ -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.+"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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]"
|
||||
|
@ -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;
|
||||
|
Loading…
Reference in New Issue
Block a user