From b29d3266e83b86d3bdedadb6f4a2686e6f107c6d Mon Sep 17 00:00:00 2001 From: albertprz Date: Wed, 1 May 2024 21:26:14 +0200 Subject: [PATCH] TCO for user defined functions via recur --- README.md | 60 +++++++++++++++++++++---- lib/Prelude.pursh | 44 ++++++++++-------- spago.dhall | 1 + src/AppStore.purs | 2 +- src/Components/Editor/Suggestion.purs | 1 - src/Components/Spreadsheet/Handler.purs | 6 +-- src/Evaluator/Common.purs | 27 +++++++++-- src/Evaluator/Expression.purs | 36 ++++++++------- src/Interpreter/Formula.purs | 3 ++ src/Parser/FnDef.purs | 4 ++ src/Routes.purs | 1 - src/SyntaxTree/Common.purs | 5 --- src/SyntaxTree/FnDef.purs | 4 ++ src/Utils/Number.purs | 1 - test/Interpreter/ExpressionSpec.purs | 15 ++++--- 15 files changed, 145 insertions(+), 65 deletions(-) diff --git a/README.md b/README.md index ee1f7fb..af1ff47 100644 --- a/README.md +++ b/README.md @@ -25,16 +25,14 @@ for use for enterprise, personal & educational purposes. - [✔️] Persist user defined formulas, spreadsheet data, functions & operators in the browser local storage. +- Format automatically formulas when evaluated. + - Add the capability for a user to create, modify or delete global functions & operators through an auxiliary modal in the Explorer view. - Enable the use of formulas for filtering & sorting rows. -- Include Opt-in automatic formatting for formulas when evaluated. - - Support Import & Export of spreadsheets from and to Excel and Google Sheets with the proper mapping of cell values & formulas. -- Expose customization options for navigation, keybindings, spreadsheet behaviour as well as display and themes configuration. - - Support authenticated persistence & retrieval from a catalog of private spreadsheets via a future backend. @@ -67,23 +65,69 @@ $ npm run serve ## Keybindings +#### General + +
+ +| Key Combination | Action | +| --------------- | ------ | +| `Control` + `J` | Next view | +| `Control` + `K` | Previous view | + +
+ + +#### Spreadsheet table +
| Key Combination | Action | | --------------- | ------ | | ↑ ↓ ← → | Cell navigation | | `h` `j` `k` `l` | Cell navigation (Vim like) | +| `Shift` + ↑ ↓ ← → | Cell selection | +| `Shift` + `Hover` | Cell selection | | `Tab` | Go to next cell | | `Shift` + `Tab` | Go to previous cell | | `Enter` | Edit cell value | | `Control` + `Enter` | Edit formula | -| `Shift` + `Navigation` | Cell selection | | `Backspace` | Delete cell/s | | `Control` + `G` | Go to cell | | `Control` + `A` | Select all cells | -| `Control` + `C` | Copy cells/s | -| `Control` + `V` | Paste cells/s | -| `Control` + `X` | Cut cells/s | +| `Control` + `C` | Copy cell/s | +| `Control` + `V` | Paste cell/s | +| `Control` + `X` | Cut cell/s | + +
+ +#### Formula Editor + +
+ +| Key Combination | Action | +| --------------- | ------ | +| `Tab` | Switch out of editor | +| `Control` + `Enter` | Submit formula | +| `Enter` | Autocomplete with current suggestion +| ↑ | Previous autocomplete suggestion | +| ↓ | Next autocomplete suggestion | +| `Shift` + `Tab` | Previous autocomplete suggestion | +| `Tab` | Next autocomplete suggestion | +| `Control` + `Click` | Go to function / module documentation | +| `Control` + `D` | Go to function / module documentation | + +
+ +#### Function Explorer + +
+ +| Key Combination | Action | +| --------------- | ------ | +| `Control` + `M` | Switch module | +| `Control` + `F` | Search for function | +| ↑ ↓ | Previous / next function | +| `Shift` + `Tab` `Tab` | Previous / next function |
diff --git a/lib/Prelude.pursh b/lib/Prelude.pursh index 91c9550..4f09b21 100644 --- a/lib/Prelude.pursh +++ b/lib/Prelude.pursh @@ -94,29 +94,33 @@ def map (f: A -> B, xs: [A]): [B] = // Maps a unary function over a collection // >>> _ / 2, [1, 3, 5, 7] // >>> _ ++ "x", ["a", "c", "c"] - switch (xs) { - | [] => [] - | [ x, xs @ ... ] => f (x) +: map (f, xs) + go (f, xs, []) where { + | go (f, xs, acc) = switch (xs) { + | [] => acc + | [ xs @ ... , x ] => recur (f, xs, f (x) +: acc) + } } def filter (f: A -> Boolean, xs: [A]): [A] = // Uses a predicate to filter a collection // >>> x -> x % 2 == 0, [1, 2, 3, 4] // >>> x -> length (x) > 2, ["abc", "f"] - switch (xs) { - | [] => [] - | [ x, xs @ ... ] ? f(x) => x +: filter (f, xs) - ? otherwise => filter (f, xs) + go (f, xs, []) where { + | go (f, xs, acc) = switch (xs) { + | [] => acc + | [ x, xs @ ... ] ? f(x) => recur (f, xs, x +: acc) + ? otherwise => recur (f, xs, acc) + } } def reduce (f: B -> A -> B, start: B, xs: [A]): B = // Uses a function and an initial value to accumulate over a collection // >>> '+, 7, [1, 2, 3, 4] // >>> '++, "hello", ["abc", "f"] - reduceRight (f, start, reverse (xs)) where { - | reduceRight (f, start, xs) = switch (xs) { - | [] => start - | [ x, xs @ ... ] => f (reduceRight (f, start, xs), x) + go (f, start, reverse (xs), start) where { + | go (f, start, xs, acc) = switch (xs) { + | [] => acc + | [ x, xs @ ... ] => recur (f, start, xs, f(acc, x)) } } @@ -132,19 +136,23 @@ def zipWith (f: A -> B -> C, xs: [A], ys: [B]): [C] = // Maps a binary function over two collections // >>> '-, [1, 2, 3], [5, 6, 7] // >>> '++, ["a", "b"], ["c", "d"] - cond { - ? isEmpty (xs) || isEmpty (ys) => [] - ? otherwise => - f (head (xs), head (ys)) +: zipWith (f, tail (xs), tail (ys)) + go (f, xs, ys, []) where { + | go (f, xs, ys, acc) = cond { + ? isEmpty (xs) || isEmpty (ys) => acc + ? otherwise => recur (f, tail (xs), tail (ys), + f (head (xs), head (ys)) +: acc) + } } def iterate (f: A -> A, start: A, n: Int): [A] = // Generates a collection by applying a function n times with an initial value // >>> _ * 2, 1, 6 // >>> _ ++ "x", "a", 3 - cond { - ? n == 0 => [start] - ? otherwise => start +: iterate (f, f (start), n - 1) + go (f, start, n, []) where { + | go (f, start, n, acc) = cond { + ? n == 0 => reverse (acc) + ? otherwise => recur (f, f (start), n - 1, start +: acc) + } } def isEmpty (xs: [A]): Boolean = diff --git a/spago.dhall b/spago.dhall index e65cd82..572ef91 100644 --- a/spago.dhall +++ b/spago.dhall @@ -44,6 +44,7 @@ , "safe-coerce" , "strings" , "stringutils" + , "tailrec" , "tecton" , "tecton-halogen" , "transformers" diff --git a/src/AppStore.purs b/src/AppStore.purs index 045f95e..da50d96 100644 --- a/src/AppStore.purs +++ b/src/AppStore.purs @@ -15,7 +15,6 @@ import Data.HashMap as HashMap import Data.Set as Set import Data.Set.NonEmpty as NonEmptySet import Data.Tree.Zipper (fromTree) -import Effect.Console (log) import Effect.Console as Logger import Foreign (readArray, readString, unsafeToForeign) import Foreign.Index ((!)) @@ -63,6 +62,7 @@ mkLocalContext store = { module': preludeModule , localFnsMap: HashMap.empty , argsMap: HashMap.empty + , fnInfo: Nothing , scope: zero , scopeLoc: fromTree $ mkLeaf zero , lambdaCount: zero diff --git a/src/Components/Editor/Suggestion.purs b/src/Components/Editor/Suggestion.purs index 49d3bcb..ef97b8c 100644 --- a/src/Components/Editor/Suggestion.purs +++ b/src/Components/Editor/Suggestion.purs @@ -11,7 +11,6 @@ import Bookhound.Parser (Parser, runParser) import Bookhound.ParserCombinators (is) import Bookhound.Parsers.Char (lower) import Data.Array as Array -import Data.Generic.Rep (class Generic) import Data.HashMap as HashMap import Data.Set as Set import Data.String.CodeUnits (indexOf', lastIndexOf') diff --git a/src/Components/Spreadsheet/Handler.purs b/src/Components/Spreadsheet/Handler.purs index 25c7d04..a40fe4b 100644 --- a/src/Components/Spreadsheet/Handler.purs +++ b/src/Components/Spreadsheet/Handler.purs @@ -153,9 +153,7 @@ handleAction (KeyDown Space _) = do handleAction (KeyDown Delete _) = deleteCells -handleAction (KeyDown Shift ev) = prevent ev - -handleAction (KeyDown Control ev) = withPrevent ev $ +handleAction (KeyDown Shift ev) = withPrevent ev $ modify_ _ { selectionState = InProgressSelection } handleAction (KeyDown (CharKeyCode 'A') ev) @@ -176,7 +174,7 @@ handleAction (KeyDown (CharKeyCode 'G') ev) handleAction (KeyDown _ _) = pure unit -handleAction (KeyUp Control ev) = withPrevent ev $ +handleAction (KeyUp Shift ev) = withPrevent ev $ modify_ _ { selectionState = NotStartedSelection } handleAction (KeyUp _ _) = diff --git a/src/Evaluator/Common.purs b/src/Evaluator/Common.purs index c438ad6..4b5f429 100644 --- a/src/Evaluator/Common.purs +++ b/src/Evaluator/Common.purs @@ -11,6 +11,9 @@ import App.SyntaxTree.FnDef (Associativity(..), BuiltinFnInfo, FnBody(..), FnDef import App.SyntaxTree.Pattern (Pattern(..)) import Bookhound.Parser (runParser) import Bookhound.ParserCombinators (is) +import Bookhound.Utils.Array (hasSome) +import Control.Monad.Rec.Class (Step(..), tailRecM) +import Control.Monad.State (State) import Data.Array as Array import Data.Array.NonEmpty as NonEmptyArray import Data.HashMap as HashMap @@ -30,12 +33,13 @@ type LocalFormulaCtx = , localFnsMap :: HashMap (Scope /\ Var) FnInfo , argsMap :: HashMap (Scope /\ Var) FnInfo , module' :: Module + , fnInfo :: Maybe FnInfo , scope :: Scope , scopeLoc :: Loc Scope , lambdaCount :: Int } -type EvalM a = forall m. MonadState LocalFormulaCtx m => ExceptT EvalError m a +type EvalM a = ExceptT EvalError (State LocalFormulaCtx) a registerBindings :: Array FnDef -> EvalM Unit registerBindings bindings = do @@ -49,6 +53,18 @@ registerBindings bindings = do st.scopeLoc } +tailCallWrapper :: EvalM Object -> EvalM Object +tailCallWrapper action = untilLoopEnd \argObjs -> do + when (hasSome argObjs) do + { fnInfo } <- get + (put =<< getNewFnState (unsafeFromJust fnInfo) (Object' <$> argObjs)) + action + +untilLoopEnd :: (Array Object -> EvalM Object) -> EvalM Object +untilLoopEnd action = [] # tailRecM \args -> action args <#> case _ of + LoopObj x -> Loop x + x -> Done x + registerLocalFn :: Scope -> FnDef -> EvalM Unit registerLocalFn scope fnDef = modify_ \st -> st { localFnsMap = insertFnDef scope fnDef st.localFnsMap } @@ -150,23 +166,28 @@ insertFnDef scope (FnDef fnName params returnType doc body) = } getNewFnState :: FnInfo -> Array FnBody -> EvalM LocalFormulaCtx -getNewFnState (FnInfo { id: maybeFnId, scope, params, argsMap }) fnArgs = +getNewFnState + fnInfo@(FnInfo { id: maybeFnId, scope, params, argsMap }) + fnArgs = do st <- get let - newArgsMap = HashMap.union argsMap $ HashMap.union argBindings st.argsMap + newArgsMap = HashMap.union argsMap + $ HashMap.union argBindings st.argsMap pure $ case maybeFnId of Just { fnModule } -> st { argsMap = newArgsMap , localFnsMap = HashMap.empty , module' = fnModule + , fnInfo = Just fnInfo , scope = zero , scopeLoc = fromTree $ mkLeaf zero } Nothing -> st { argsMap = newArgsMap , scope = scope + , fnInfo = Just fnInfo , scopeLoc = goToNode scope st.scopeLoc } where diff --git a/src/Evaluator/Expression.purs b/src/Evaluator/Expression.purs index 183d6be..e176fec 100644 --- a/src/Evaluator/Expression.purs +++ b/src/Evaluator/Expression.purs @@ -2,7 +2,7 @@ module App.Evaluator.Expression where import FatPrelude -import App.Evaluator.Common (EvalM, LocalFormulaCtx, extractAlias, getNewFnState, isSpread, lambdaId, lookupBuiltinFn, lookupFn, lookupOperator, registerArg, registerBindings, resetFnScope, substituteFnArgs, varFn) +import App.Evaluator.Common (EvalM, LocalFormulaCtx, extractAlias, getNewFnState, isSpread, lambdaId, lookupBuiltinFn, lookupFn, lookupOperator, registerArg, registerBindings, resetFnScope, substituteFnArgs, tailCallWrapper, varFn) import App.Evaluator.Errors (EvalError(..), MatchError(..), TypeError(..), raiseError) import App.Evaluator.Object (cellValueToObj, extractBool, extractNList) import App.SyntaxTree.Common (QVar(..), Var(..)) @@ -23,6 +23,10 @@ evalExpr (FnApply fnExpr args) = do BuiltinFnObj fnInfo -> evalBuiltinFn fnInfo argObjs _ -> raiseError $ TypeError' $ NotAFunction fnObj +evalExpr (Recur args) = do + argObjs <- traverse (\x -> evalExpr x) args + pure $ LoopObj argObjs + evalExpr (LambdaFn params body) = do { lambdaCount } <- modify \st -> st { lambdaCount = inc st.lambdaCount } let lambdaVar = Var $ lambdaId lambdaCount @@ -49,20 +53,10 @@ evalExpr (RightOpSection body fnOp) = do evalExpr (WhereExpr fnBody bindings) = registerBindings bindings *> evalExpr fnBody -evalExpr (CondExpr conds) = do - st <- get - let - newScope = inc $ fromMaybe st.scope $ maximum $ toTree st.scopeLoc - newSt = st - { scopeLoc = insertChild (mkLeaf newScope) st.scopeLoc - , scope = newScope - } - except $ - findMapEither (MatchError' NonExhaustiveGuard) - (evalGuardedFnBody newSt) - conds +evalExpr (CondExpr conds) = + tailCallWrapper $ evalMaybeGuardedFnBody $ Guarded conds -evalExpr (SwitchExpr matchee cases) = do +evalExpr (SwitchExpr matchee cases) = tailCallWrapper do result <- evalExpr matchee st <- get let @@ -237,8 +231,18 @@ evalCaseBinding st matchee (CaseBinding pattern body) = evalMaybeGuardedFnBody :: MaybeGuardedFnBody -> EvalM Object -evalMaybeGuardedFnBody (Guarded conds) = - evalExpr $ CondExpr conds +evalMaybeGuardedFnBody (Guarded conds) = do + st <- get + let + newScope = inc $ fromMaybe st.scope $ maximum $ toTree st.scopeLoc + newSt = st + { scopeLoc = insertChild (mkLeaf newScope) st.scopeLoc + , scope = newScope + } + except $ + findMapEither (MatchError' NonExhaustiveGuard) + (evalGuardedFnBody newSt) + conds evalMaybeGuardedFnBody (Standard body) = evalExpr body diff --git a/src/Interpreter/Formula.purs b/src/Interpreter/Formula.purs index 033969b..a3500fa 100644 --- a/src/Interpreter/Formula.purs +++ b/src/Interpreter/Formula.purs @@ -45,6 +45,9 @@ extractCells :: FnBody -> Set Cell extractCells (FnApply fnExpr args) = extractCells fnExpr <> foldMap extractCells args +extractCells (Recur args) = + foldMap extractCells args + extractCells (LambdaFn _ body) = extractCells body diff --git a/src/Parser/FnDef.purs b/src/Parser/FnDef.purs index a2be12a..e7690a0 100644 --- a/src/Parser/FnDef.purs +++ b/src/Parser/FnDef.purs @@ -48,6 +48,9 @@ fnBody = whereExpr <|> topLevelExpr <$> token fnForm <*> argListOf openForm + recur = defer \_ -> Recur + <$> (isToken "recur" *> argListOf openForm) + lambdaFn = defer \_ -> LambdaFn <$> (argListOf var <|> pure <$> var) <*> (isToken "->" *> fnBody) @@ -99,6 +102,7 @@ fnBody = whereExpr <|> topLevelExpr <|> arrayRange <|> (CellValue' <$> cellValue) <|> (Cell' <$> cell) + <|> recur <|> fnOp <|> fnApply <|> fnVar diff --git a/src/Routes.purs b/src/Routes.purs index 31c6c18..e1f23a4 100644 --- a/src/Routes.purs +++ b/src/Routes.purs @@ -5,7 +5,6 @@ import FatPrelude hiding (optional, sum, (/)) import App.Editor.Suggestion (SuggestionTerm(..), showFullTerm) import App.Parser.Common (module', qVar, qVarOp) import Bookhound.Parser (runParser) -import Data.Generic.Rep (class Generic) import Halogen.Hooks (Hook) import Halogen.Hooks.HookM (HookM) import Halogen.Router.Class (class MonadRouter) diff --git a/src/SyntaxTree/Common.purs b/src/SyntaxTree/Common.purs index 9a6deee..d7ce2c7 100644 --- a/src/SyntaxTree/Common.purs +++ b/src/SyntaxTree/Common.purs @@ -3,11 +3,6 @@ module App.SyntaxTree.Common where import FatPrelude import Prim hiding (Row) -import Data.Argonaut (class DecodeJson, class EncodeJson) -import Data.Argonaut.Decode.Generic (genericDecodeJson) -import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Data.Generic.Rep (class Generic) - newtype Var = Var String derive newtype instance Eq Var diff --git a/src/SyntaxTree/FnDef.purs b/src/SyntaxTree/FnDef.purs index 3c3d16a..eb4e254 100644 --- a/src/SyntaxTree/FnDef.purs +++ b/src/SyntaxTree/FnDef.purs @@ -28,6 +28,7 @@ data FnDef = FnDef Var (Array (Var /\ Maybe Type)) (Maybe Type) String data FnBody = FnApply FnBody (Array FnBody) + | Recur (Array FnBody) | LambdaFn (Array Var) FnBody | InfixFnApply (Array QVarOp) (Array FnBody) | LeftOpSection QVarOp FnBody @@ -72,6 +73,7 @@ data Object | FnObj FnInfo | BuiltinFnObj BuiltinFnInfo | NullObj + | LoopObj (Array Object) newtype FnInfo = FnInfo { id :: Maybe FnId @@ -149,6 +151,7 @@ instance Show Object where FnObj _ -> "function" BuiltinFnObj _ -> "builtin-function" NullObj -> "null" + LoopObj _ -> "loop" instance Eq Object where eq (BoolObj x) (BoolObj y) = x == y @@ -212,6 +215,7 @@ objectToSerialObject = case _ of FnObj _ -> SerialNullObj BuiltinFnObj _ -> SerialNullObj NullObj -> SerialNullObj + LoopObj _ -> SerialNullObj derive newtype instance Eq Scope derive newtype instance Ord Scope diff --git a/src/Utils/Number.purs b/src/Utils/Number.purs index ec90eb2..96a38a9 100644 --- a/src/Utils/Number.purs +++ b/src/Utils/Number.purs @@ -29,4 +29,3 @@ abs x coalesce :: forall a. Semiring a => Maybe a -> a coalesce = fromMaybe zero - diff --git a/test/Interpreter/ExpressionSpec.purs b/test/Interpreter/ExpressionSpec.purs index e244abb..36a648f 100644 --- a/test/Interpreter/ExpressionSpec.purs +++ b/test/Interpreter/ExpressionSpec.purs @@ -25,7 +25,7 @@ spec = describe "Interpreter.Expression" do describe "works for recursive functions" do - it "Fibonacci" $ + it "Non tail calls (can stack overflow)" $ runExpr """ fib (10) where { @@ -38,17 +38,17 @@ spec = describe "Interpreter.Expression" do """ `shouldEqual` pure (IntObj 55) - it "Map" $ + it "Tail calls (cannot stack overflow)" $ runExpr """ - myMap (x -> x * x, [1 .. 4]) where { - | myMap (f, xs) = switch (xs) { - | [] => [] - | [ xs @ ... , x ] => myMap (f, xs) :+ f (x) + last (myMap (x -> x * x, [1 .. 5000], [])) where { + | myMap (f, xs, ys) = switch (xs) { + | [] => ys + | [ xs @ ... , x ] => recur (f, xs, f (x) +: ys) } } """ `shouldEqual` pure - (ArrayObj (IntObj <$> [ 1, 4, 9, 16 ])) + (IntObj 25000000) describe "works for partially applied functions" do @@ -294,6 +294,7 @@ formulaCtx = unsafePerformEffect $ , localFnsMap: HashMap.empty , argsMap: HashMap.empty , modules: Set.empty + , fnInfo: Nothing , module': preludeModule , scope: zero , scopeLoc: fromTree $ mkLeaf zero