spade 0.1.0.9 → 0.1.0.10

raw patch · 22 files changed

+304/−75 lines, 22 filesdep +bounded-queuedep +deepseq

Dependencies added: bounded-queue, deepseq

Files

• ChangeLog.md +5/−0
• docs/functions/concurrency.md +5/−0
• samples/factorial-recursive.spd +8/−0
• samples/fib-cache.spd +18/−0
• samples/fib-generator.spd +15/−0
• spade.cabal +12/−3
• src/Common.hs +5/−1
• src/Compiler/AST/Expression.hs +17/−5
• src/Compiler/AST/FunctionDef.hs +45/−2
• src/Compiler/AST/FunctionStatement.hs +15/−7
• src/Compiler/AST/Parser/Common.hs +1/−1
• src/Compiler/Lexer/Comments.hs +5/−1
• src/Compiler/Lexer/Identifiers.hs +5/−1
• src/Compiler/Lexer/Literals.hs +5/−1
• src/Compiler/Lexer/Operators.hs +7/−2
• src/IDE/IDE.hs +12/−12
• src/Interpreter/Common.hs +57/−7
• src/Interpreter/Interpreter.hs +4/−6
• src/Interpreter/Lib/Misc.hs +16/−8
• src/UI/Widgets/Common.hs +12/−3
• src/UI/Widgets/LogWidget.hs +34/−14
• test/Interpreter/InterpreterSpec.hs +1/−1

@@ -1,5 +1,10 @@ # Changelog for S.P.A.D.E +## Unreleased++* Fix space leak when updating arrays and maps.+* Fix redraw overlap when `log` function is used.+ ## 0.1.0.9  * Add step option to for loops.

@@ -161,6 +161,11 @@ #### newref  Create a new mutable reference with with initial value set to the argument.+Mutable references might appear to serve the same purpose as global variables+but differ in an important way. Modification made to a global variable from a+thread will not be visible from other threads. So if you want to make that+happen, you ll have to use a mutable reference that is shared between the+threads.  #### readref 

@@ -0,0 +1,8 @@+proc fact(n)+  if (n == 1) then+    return 1+  else+    return (n * fact((n - 1)))+  endif+endproc+println(fact(10000))

@@ -0,0 +1,18 @@+let cache = newref({})++proc fib(n)+  if (n < 1) then+    return 1+  else+    let c = readref(cache)+    if haskey(c, tostring(n)) then+      return c[tostring(n)]+    else+      let r = (fib((n - 1)) + fib((n - 2)))+      modifyref(cache, fn (c) addkey(c, tostring(n), r) endfn)+     return r+    endif+  endif+endproc++println(fib(135))

@@ -0,0 +1,15 @@+proc fib_generator()+  let a = 0+  let b = 1+  loop+    yield b+    let c = (a + b)+    let a = b+    let b = c+  endloop+endproc++let fib_gen = fib_generator()+for i = 1 to 100+  println(next(fib_gen))+endfor

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack  name:           spade-version:        0.1.0.9+version:        0.1.0.10 synopsis:       A simple programming and debugging environment. description:    A simple weakly typed, dynamic, interpreted programming langauge and terminal IDE. category:       language, interpreter, ide@@ -43,6 +43,9 @@     samples/char-animation.spd     samples/char-graphics.spd     samples/concurrency.spd+    samples/factorial-recursive.spd+    samples/fib-cache.spd+    samples/fib-generator.spd     samples/filechecker.spd     samples/mandelbrot.spd     samples/paratrooper.spd@@ -175,10 +178,12 @@     , aeson >=2.1.2 && <2.2     , ansi-terminal >=0.11.5 && <0.12     , base >=4.16.3 && <4.17+    , bounded-queue >=1.0.0 && <1.1     , bytestring >=0.11.3 && <0.12     , constraints >=0.13.4 && <0.14     , containers >=0.6.5 && <0.7     , cryptonite ==0.30.*+    , deepseq >=1.4.6 && <1.5     , directory >=1.3.6 && <1.4     , exceptions >=0.10.4 && <0.11     , file-embed >=0.0.15 && <0.1@@ -268,17 +273,19 @@       ViewPatterns       PackageImports       InstanceSigs-  ghc-options: -Wall -Wno-type-defaults -threaded -fPIC+  ghc-options: -Wall -Wno-type-defaults -threaded -fPIC -rtsopts   build-depends:       Decimal >=0.5.2 && <0.6     , WAVE >=0.1.6 && <0.2     , aeson >=2.1.2 && <2.2     , ansi-terminal >=0.11.5 && <0.12     , base >=4.16.3 && <4.17+    , bounded-queue >=1.0.0 && <1.1     , bytestring >=0.11.3 && <0.12     , constraints >=0.13.4 && <0.14     , containers >=0.6.5 && <0.7     , cryptonite ==0.30.*+    , deepseq >=1.4.6 && <1.5     , directory >=1.3.6 && <1.4     , exceptions >=0.10.4 && <0.11     , file-embed >=0.0.15 && <0.1@@ -391,10 +398,12 @@     , aeson >=2.1.2 && <2.2     , ansi-terminal >=0.11.5 && <0.12     , base >=4.16.3 && <4.17+    , bounded-queue >=1.0.0 && <1.1     , bytestring >=0.11.3 && <0.12     , constraints >=0.13.4 && <0.14     , containers >=0.6.5 && <0.7     , cryptonite ==0.30.*+    , deepseq >=1.4.6 && <1.5     , directory >=1.3.6 && <1.4     , exceptions >=0.10.4 && <0.11     , file-embed >=0.0.15 && <0.1

@@ -5,6 +5,8 @@  import Control.Concurrent import Control.Exception+import GHC.Generics+import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad import Data.List as DL@@ -139,7 +141,9 @@   { lcLine :: Int -- Line, obviously.   , lcColumn :: Int -- Column, obviously   , lcOffset :: Int -- Char offset from start of the token.-  } deriving (TH.Lift, Show, Eq)+  } deriving (Generic, TH.Lift, Show, Eq)++instance NFData Location  instance HReadable Location where   hReadable l = T.pack $ "Line: " <> (show (lcLine l)) <> " Column: " <> show (lcColumn l)

@@ -1,6 +1,8 @@ module Compiler.AST.Expression where  import Control.Applicative+import Control.DeepSeq+import GHC.Generics import Control.Monad import Data.List.NonEmpty as NE import qualified Data.Map as Map@@ -21,8 +23,10 @@  = SubscriptExpr Subscript ExpressionWithLoc  | PropertySubscript Subscript Identifier  | NoSubscript Identifier- deriving (Eq, Show)+ deriving (Eq, Show, Generic) +instance NFData Subscript+ instance ToSource Subscript where   toSource = \case     SubscriptExpr sub i     -> T.concat [toSource sub, "[", toSource i, "]"]@@ -39,8 +43,10 @@   = LAtomic Literal   | LArray [ExpressionWithLoc]   | LObject (Map.Map Text ExpressionWithLoc)-  deriving (Eq, Show)+  deriving (Eq, Show, Generic) +instance NFData LiteralExpression+ instance ToSource LiteralExpression where   toSource (LAtomic l) = toSource l   toSource (LArray l)  = T.concat ["[", T.intercalate ", " (toSource <$> l), "]"]@@ -58,8 +64,10 @@ data SubscriptedExpression   = EArraySubscript ExpressionWithLoc ExpressionWithLoc   | EPropertySubscript ExpressionWithLoc Identifier-  deriving (Show, Eq)+  deriving (Show, Generic, Eq) +instance NFData SubscriptedExpression+ instance ToSource SubscriptedExpression where   toSource = \case     EArraySubscript sub i    -> T.concat [toSource sub, "[", toSource i, "]"]@@ -72,8 +80,10 @@     ]  data ExpressionWithLoc = ExpressionWithLoc { elExpression :: Expression, elLocation ::  Location }-  deriving (Show)+  deriving (Show, Generic) +instance NFData ExpressionWithLoc+ instance Eq ExpressionWithLoc where   (ExpressionWithLoc e1 _) == (ExpressionWithLoc e2 _) = e1 == e2 @@ -90,7 +100,9 @@   | EParan ExpressionWithLoc   | EUnnamedFn [Identifier] ExpressionWithLoc   | ENegated ExpressionWithLoc-  deriving (Show)+  deriving (Show, Generic)++instance NFData Expression  instance Eq Expression where -- Specialized implementation to implement equality for EParen wrapped expressions   (ELiteral l1) == (ELiteral l2) = l1 == l2

@@ -1,6 +1,8 @@ module Compiler.AST.FunctionDef where  import Common+import Control.DeepSeq+import GHC.Generics import Control.Applicative import Data.List as L import Data.List.NonEmpty as NE@@ -16,8 +18,10 @@  data FunctionDef   = FunctionDef Bool Identifier [Identifier] (NonEmpty FunctionStatementWithLoc)-  deriving (Show, Eq)+  deriving (Show, Generic, Eq) +instance NFData FunctionDef+ instance HasAstParser FunctionDef where   astParser = nameParser "Function Definition" $ do     surroundWs_ (parseKeyword KwProc)@@ -39,4 +43,43 @@       [toSourcePretty (i+1) (NE.toList stms)] <> [nlt, indent i, toSource KwEndProc]  instance HasGen FunctionDef where-  getGen = (FunctionDef False) <$> getGen <*> getGen <*> (nonEmptyGen getGen)+  getGen = do+    isGen <- bool+    stms <- case isGen of+      True -> functionStmsWithYield+      False -> functionStmsWithoutYield+    (FunctionDef isGen) <$> getGen <*> getGen <*> (pure stms)++hasYield :: NonEmpty FunctionStatementWithLoc -> Bool+hasYield fustms = case fustms of+  ((FunctionStatementWithLoc stm _) :|  []) -> hasYield' stm+  ((FunctionStatementWithLoc stm _) :|  (h:t)) -> if hasYield' stm+    then True+    else hasYield (h :| t)+  where+    hasYield' = \case+      Let _ _ _ -> False+      Call _ _ _ -> False+      If _ stms1 stms2 -> hasYield stms1 || hasYield stms2+      IfThen _ stms -> hasYield stms+      MultiIf _ stms1 (NE.map snd -> branches) mstms2 ->+        hasYield stms1 || (or (hasYield <$> branches)) ||+          (case mstms2 of+            Nothing -> False+            Just stms -> hasYield stms)+      For _ _ _ stms _ -> hasYield stms+      ForEach _ _ stms -> hasYield stms+      While _ stms -> hasYield stms+      Loop stms -> hasYield stms+      Yield _ -> True+      _ -> False++functionStmsWithoutYield :: Gen (NonEmpty FunctionStatementWithLoc)+functionStmsWithoutYield = do+  stms <- nonEmptyGen getGen+  if hasYield stms then functionStmsWithoutYield else pure stms++functionStmsWithYield :: Gen (NonEmpty FunctionStatementWithLoc)+functionStmsWithYield = do+  stms <- nonEmptyGen getGen+  if hasYield stms then pure stms else  functionStmsWithYield

@@ -4,6 +4,8 @@ import Data.List.NonEmpty as NE import Data.Text as T import Data.Maybe (isJust)+import GHC.Generics+import Control.DeepSeq  import Common import Compiler.AST.Common@@ -17,8 +19,10 @@  data FunctionStatementWithLoc   = FunctionStatementWithLoc FunctionStatement Location-  deriving Show+  deriving (Show, Generic) +instance NFData FunctionStatementWithLoc+ instance Eq FunctionStatementWithLoc where   (FunctionStatementWithLoc fs1 _) == (FunctionStatementWithLoc fs2 _) = fs1 == fs2 @@ -38,7 +42,7 @@  data FunctionStatement   = Let Subscript IsGlobal ExpressionWithLoc-  | Call ExpressionWithLoc+  | Call ExpressionWithLoc [ExpressionWithLoc] Bool   | If ExpressionWithLoc (NonEmpty FunctionStatementWithLoc) (NonEmpty FunctionStatementWithLoc)   | MultiIf ExpressionWithLoc (NonEmpty FunctionStatementWithLoc) (NonEmpty (ExpressionWithLoc, NonEmpty FunctionStatementWithLoc)) (Maybe (NonEmpty FunctionStatementWithLoc))   | IfThen ExpressionWithLoc (NonEmpty FunctionStatementWithLoc)@@ -51,8 +55,10 @@   | Break   | Pass   | FnComment Comment-  deriving (Show, Eq)+  deriving (Show, Eq, Generic) +instance NFData FunctionStatement+ instance ToSource FunctionStatement where   toSourcePretty i Break = T.concat [indent i, toSource KwBreak]   toSourcePretty i Pass = T.concat [indent i, toSource KwPass]@@ -61,8 +67,8 @@     T.concat [indent i, toSource KwLet, wst, toSource idf, wst, toSource KwAssignment, wst, toSource expr]   toSourcePretty i (Let idf True expr) =     T.concat [indent i, toSource KwLet, wst, toSource KwGlobal, wst, toSource idf, wst, toSource KwAssignment, wst, toSource expr]-  toSourcePretty i (Call expr) =-    T.concat $ [indent i, toSource expr]+  toSourcePretty i (Call ce args _) =+    T.concat $ [indent i, toSource ce, toSource DlParenOpen] <> [T.intercalate ", " (toSource <$> args)] <>  [toSource DlParenClose]   toSourcePretty i (Return expr) = T.concat $ [indent i, toSource KwReturn, wst, toSource expr]   toSourcePretty i (Yield expr) = T.concat $ [indent i, toSource KwYield, wst, toSource expr]   toSourcePretty i (ForEach idf expr1 stms) =@@ -124,7 +130,7 @@ instance HasGen FunctionStatement where   getGen = recursive choice     [ Let <$> getGen <*> bool <*> getGen-    , Call <$> getGen+    , Call <$> (pure $ ExpressionWithLoc (EVar "somefunc") emptyLocation) <*> getGen <*> (pure False)     , Return <$> getGen     , Yield <$> getGen     , FnComment <$> getGen@@ -174,7 +180,9 @@ callStatementParser :: AstParser FunctionStatement callStatementParser = nameParser "Function call" $ do   expr <- surroundWs (astParser @ExpressionWithLoc)-  pure $ Call expr+  case expr of+    ExpressionWithLoc (ECall ce args tc) _ -> pure $ Call ce args tc+    _ -> fail "Unexpected expression"  loopParser :: AstParser FunctionStatement loopParser = nameParser "Loop Statement" $ do

@@ -20,7 +20,7 @@  instance HaveLocation AstParserState where   getLocation (astInput -> (t:_)) =  tkLocation t-  getLocation _ = error "No location for empty input"+  getLocation _ = emptyLocation  instance HasEmpty AstParserState where   isEmpty s = astInput s == []

@@ -1,14 +1,18 @@ module Compiler.Lexer.Comments where  import Common+import Control.DeepSeq import Control.Applicative+import GHC.Generics import Control.Monad import Data.Text as T import Parser import Test.Common  newtype Comment = Comment Text-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)++instance NFData Comment  commentPrefix :: Text commentPrefix = "-- "

@@ -1,6 +1,8 @@ module Compiler.Lexer.Identifiers where  import Common+import GHC.Generics+import Control.DeepSeq import Control.Applicative import Data.Char import Data.String@@ -9,7 +11,9 @@ import Test.Common  newtype Identifier = Identifier { unIdentifer :: Text }-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic)++instance NFData Identifier  instance IsString Identifier where   fromString = Identifier . T.pack

@@ -1,6 +1,8 @@ module Compiler.Lexer.Literals where  import Control.Applicative+import GHC.Generics+import Control.DeepSeq import Control.Monad import qualified Data.ByteString as BS import Data.Char@@ -20,7 +22,9 @@   | LitFloat Decimal -- This needs to be a decimal so that string round tripping can work.   | LitBool Bool   | LitBytes BS.ByteString-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)++instance NFData Literal  instance HasGen Literal where   getGen = choice

@@ -1,10 +1,13 @@ module Compiler.Lexer.Operators where  import Common-import Control.Applicative import Parser import Test.Common +import GHC.Generics+import Control.DeepSeq+import Control.Applicative+ data Operator   = OpAnd   | OpOr@@ -18,7 +21,9 @@   | OpMinus   | OpStar   | OpDivide-  deriving (Show, Ord, Eq, Enum, Bounded)+  deriving (Show, Generic, Ord, Eq, Enum, Bounded)++instance NFData Operator  instance HasParser Operator where   parser

@@ -141,7 +141,8 @@   (keywords, builtIns) <- extractBuiltIns   ideStateRef <- newTVarIO ideStartState   ideEventsRef <- newTChanIO-  logChannel <- newTChanIO+  logQueue <- newTBQueueIO 1+  ideDrawLock <- atomically $ newTSem 1   atomically $ writeTChan ideEventsRef (IDEAppendLog ("Loaded file: " <> (T.pack filePath)))    clipboardRef <- newIORef @(Maybe Text) Nothing@@ -253,14 +254,15 @@     let       ideRedraw :: WidgetC m => m ()       ideRedraw = do+        liftIO $ atomically $ waitTSem ideDrawLock         csClear         draw menuContainerRef         csDraw Nothing+        liftIO $ atomically $ signalTSem ideDrawLock      void $ withRunInIO $ \runInIO -> forkIO $ forever $ runInIO $ do-      msg <- liftIO $ atomically $ readTChan logChannel+      msg <- liftIO $ atomically $ readTBQueue logQueue       insertLog logRef msg-      ideRedraw      let       getActiveEditor :: WidgetC m => m (WRef EditorWidget)@@ -320,7 +322,7 @@                       , isOutputHandle = pOutHandle                       , isTerminalParams = Just (outputScreenOffset, outputScreenSize)                       , isStdoutLock = mOutBufLock-                      , isLogChannel = Just logChannel+                      , isLogChannel = SyncAutoRefresh logQueue                       })                     Start -> (\is -> is                       { isRunMode = DebugMode (DebugEnv Continue debugIn debugOut)@@ -328,7 +330,7 @@                       , isOutputHandle = pOutHandle                       , isTerminalParams = Just (outputScreenOffset, outputScreenSize)                       , isStdoutLock = mOutBufLock-                      , isLogChannel = Just logChannel+                      , isLogChannel = AsyncDeferedRefresh logQueue                       })                     _ -> error "Impossible!" @@ -386,8 +388,7 @@             liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget helpWidgetRef }))         d <- getScreenBounds         csInitialize d-        draw menuContainerRef-        csDraw Nothing+        ideRedraw         pure True       IDEStop -> do         idsDebugEnv <$> (liftIO  $ readTVarIO ideStateRef) >>= \case@@ -448,7 +449,7 @@         ideRedraw         pure True       IDEClearLog -> do-        modifyWRef logRef (\lw -> lw { lwContent = [] })+        emptyLog logRef         pure True       IDEClearOutput -> do         clearOutput outputWidgetRef@@ -470,8 +471,7 @@       IDEClearDraw -> do         d <- getScreenBounds         csInitialize d-        draw menuContainerRef-        csDraw Nothing+        ideRedraw         pure True       IDEACUpdateIdentifiers acs -> do         liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeAutocompletions = (\x -> (x, x)) <$> acs }))@@ -609,9 +609,9 @@         let dim' = Dimensions w h         csInitialize dim'         modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim' })-        draw menuContainerRef+        ideRedraw         adjustScrollOffset editorRef-        draw menuContainerRef+        ideRedraw         csDraw Nothing         pure True       IDETerminalEvent (TerminalKey ev)  -> do

@@ -1,5 +1,6 @@ module Interpreter.Common where +import Control.DeepSeq import Control.Concurrent import Control.Monad.IO.Unlift import Control.Concurrent.STM.TBQueue@@ -13,6 +14,7 @@ import Control.Exception import Control.Monad.Catch (MonadCatch, MonadThrow, throwM) import Crypto.Hash+import GHC.Generics import qualified Data.ByteString as BS import Data.IORef import Data.Kind (Type)@@ -52,7 +54,10 @@   = BuiltinCallWithDoc SomeBuiltin   | BuiltinCall BuiltInFn   | BuiltinVal Value+  deriving Generic +instance NFData BuiltinVal+ instance Show BuiltinVal where   show _ = "_builtin_" @@ -68,6 +73,9 @@   | Texture SDL.Texture   | Font SDLF.Font +instance NFData SDLValue where+  rnf _ = ()+ instance Show SDLValue where   show (Keycode k)       = "(SDL_KEY)" <> show k   show (Scancode k)      = "(SDL_SCANCODE)" <> show k@@ -81,8 +89,10 @@ data Number   = NumberInt IntType   | NumberFractional FloatType-  deriving Show+  deriving (Generic, Show) +instance NFData Number+ negateValue :: Number -> Number negateValue (NumberInt x)        = NumberInt $ negate x negateValue (NumberFractional x) = NumberFractional $ negate x@@ -114,20 +124,32 @@   compare (NumberFractional x) (NumberInt y)        = compare x (realToFrac y)  data UnNamedFn = UnNamedFn [Identifier] Scope ExpressionWithLoc-  deriving Show+  deriving (Show, Generic) +instance NFData UnNamedFn+ data ThreadInfo = ThreadInfo ThreadId (TMVar (Either SomeException Value))+  deriving Generic +instance NFData ThreadInfo where+  rnf _ = ()+ instance Show ThreadInfo where   show _ = "(ThreadInfo)"  newtype ChannelRef = ChannelRef (TChan Value) +instance NFData ChannelRef where+  rnf _ = ()+ instance Show ChannelRef where   show _ = "(ConcurrencyChannel)"  data MutableRef = MutableRef { mref :: (TMVar Value), mrsem :: TSem } +instance NFData MutableRef where+  rnf _ = ()+ instance Show MutableRef where   show _ = "(MutableRef)" @@ -141,28 +163,43 @@  data DirHandleRef = DirHandleRef Bool (TVar [DirStreamInfo]) +instance NFData DirHandleRef where+  rnf _ = ()+ instance Show DirHandleRef where   show _ = "(Directory)"  data HashContext =   MD5HashContext (Context MD5) +instance NFData HashContext where+  rnf _ = ()+ instance Show HashContext where   show _ = "(HashContext)"  data FileHandle =   FileHandle Handle +instance NFData FileHandle where+  rnf _ = ()+ instance Show FileHandle where   show _ = "(FileHandle)"  newtype ScopeRef = ScopeRef (TVar Scope) +instance NFData ScopeRef where+  rnf _ = ()+ instance Show ScopeRef where   show _ = "(scoperef)"  data GeneratorChannels = GeneratorChannels (TChan ()) (TChan (Maybe Value)) +instance NFData GeneratorChannels where+  rnf _ = ()+ instance Show GeneratorChannels where   show _ = "(generator)" @@ -191,8 +228,10 @@       -- ^ This should probably never be used directly, and should throw a CustomRTE instead       --  so that it will be caught and rethrown with location information.   | Void-  deriving Show+  deriving (Generic, Show) +instance NFData Value+ toStringVal :: Value -> Text toStringVal = \case   StringValue t                    -> t@@ -248,8 +287,10 @@ data ScopeKey   = SkIdentifier Identifier   | SkOperator Operator-  deriving (Ord, Eq)+  deriving (Ord, Eq, Generic) +instance NFData ScopeKey+ instance Show ScopeKey where   show (SkIdentifier i) = unpack $ unIdentifer i   show (SkOperator i)   = show i@@ -296,6 +337,12 @@ instance Show DebugEnv where   show _ = "{DebugEnv}" ++data LogMode+  = SyncAutoRefresh (TBQueue Text)+  | AsyncDeferedRefresh (TBQueue Text)+  | NoLog+ data InterpreterState = InterpreterState   { isLocal              :: [Scope]   , isCurrentModulePath  :: Maybe FilePath@@ -314,7 +361,7 @@   , isWidgetState        :: Maybe WidgetState   , isTerminalParams     :: Maybe (ScreenPos, Dimensions)   , isStdoutLock         :: Maybe TSem-  , isLogChannel         :: Maybe (TChan Text)+  , isLogChannel         :: LogMode   , isDefaultPrintParams :: Maybe (Text, Int, [Int])   , isDefaultFont        :: Maybe SDLF.Font   , isBgColor            :: Maybe (Word8, Word8, Word8, Word8)@@ -355,7 +402,7 @@   , isDiffRender = Nothing   , isTerminalParams = Nothing   , isStdoutLock = Nothing-  , isLogChannel = Nothing+  , isLogChannel = NoLog   , isWidgetState = Nothing   , isDefaultPrintParams = Nothing   , isDefaultFont = Nothing@@ -381,7 +428,7 @@   , isDiffRender = Nothing   , isTerminalParams = Nothing   , isStdoutLock = Nothing-  , isLogChannel = Nothing+  , isLogChannel = NoLog   , isWidgetState = Just emptyWidgetState   , isDefaultPrintParams = Just (".", 2, [3, 2, 2, 2, 2, 2, 2])   , isBgColor = Just (0, 0, 0, 255)@@ -724,6 +771,9 @@  data SomeBuiltin where   SomeBuiltin :: KnownArgs s => (NamedArgs s -> InterpretM (Maybe Value)) -> SomeBuiltin++instance NFData SomeBuiltin where+  rnf _ = ()  extractDoc :: SomeBuiltin -> [(Text, Text)] extractDoc (SomeBuiltin (_ :: NamedArgs s -> InterpretM (Maybe Value))) = toArgDoc @s

@@ -136,9 +136,7 @@         insertEmptyScope         oldFp <- isCurrentModulePath <$> getInterpretM         modifyInterpretM (\is -> is { isCurrentModulePath = Just fp })-        r <- case fndef of-          FunctionDef False _ _ _ -> runProcedure fndef-          FunctionDef True _ _ _ -> withStateClone $ runProcedure fndef+        r <- runProcedure fndef         finalModuleScope <- popModuleScope         modifyInterpretM (\is -> is { isCurrentModulePath = oldFp })         liftIO $ atomically $ writeTVar scopeRef finalModuleScope@@ -158,7 +156,7 @@         inChan <- liftIO newTChanIO         outChan <- liftIO newTChanIO         let gChans = GeneratorChannels inChan outChan-        void $ withRunInIO $ \runInIO -> forkIO $ runInIO (do+        void $ withRunInIO $ \runInIO -> forkIO $ runInIO (withStateClone $ do             modifyInterpretM (\is -> is { isGeneratorChannels = Just gChans })             void $ runProcedure $ FunctionDef False a b c             liftIO $ atomically $ writeTChan outChan Nothing@@ -396,8 +394,8 @@   sourceValue <- evaluateExpression exp'   modifyBinding isGlobal sub sourceValue   pure ProcContinue-executeStatement_ (Call expr) = do-  _ <- evaluateExpression expr+executeStatement_ (Call ce args tc) = do+  _ <- evaluateExpression_ (ECall ce args tc)   pure ProcContinue executeStatement_ (IfThen expr stms) = evaluateExpression expr >>= \case   BoolValue True -> executeStatements (NE.toList stms)

@@ -1,7 +1,9 @@ module Interpreter.Lib.Misc where -import Control.Concurrent.STM (atomically, newTVarIO, writeTChan)+import qualified Control.DeepSeq as DS+import Control.Concurrent.STM (atomically, newTVarIO) import Control.Concurrent.STM.TSem+import Control.Concurrent.STM.TBQueue import Control.Monad.IO.Class import System.Directory import System.Process@@ -12,6 +14,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Coerce+import Control.Monad.Loops (iterateWhile) import Data.Map as M import Data.Proxy import qualified Data.Scientific as S@@ -320,7 +323,7 @@  addition :: BuiltInFn addition (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (+) v1 v2-addition (ArrayValue i1 : ArrayValue i2 : []) = pure $ Just $ ArrayValue $ i1 V.++ i2+addition (ArrayValue i1 : ArrayValue i2 : []) = pure $ Just $ ArrayValue $ V.force $ i1 V.++ i2 addition a = throwBadArgs a "number/list"  substraction :: BuiltInFn@@ -364,7 +367,7 @@   Nothing -> pure $ Just $ ErrorValue $ "Key '" <> key <> "' not found in dictionary"  addkey :: BuiltInFnWithDoc '[ '("dictionary",  M.Map Text Value), '("key", Text), '("value", Value)]-addkey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> (coerce -> val) :> EmptyArgs) = pure $ Just $ ObjectValue $ M.insert key val map'+addkey (((DS.force . coerce) -> (map' :: M.Map Text Value)) :> (coerce -> key) :> (coerce -> val) :> EmptyArgs) = pure $ Just $ ObjectValue $ M.insert key val map'  builtInRepeat :: BuiltInFnWithDoc ['("count", Int), '("source", Value)] builtInRepeat ((coerce -> c) :> (coerce -> vl) :>  EmptyArgs) = pure $ Just $ ArrayValue $ V.fromList $ Prelude.take c $ repeat vl@@ -372,7 +375,7 @@ builtInTake :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)] builtInTake ((coerce -> c) :> (coerce -> vl) :>  EmptyArgs) = case vl of   TCText t -> pure $ Just $ StringValue $ T.take c t-  TCList l -> pure $ Just $ ArrayValue (V.take c l)+  TCList l -> pure $ Just $ ArrayValue (V.force $ V.take c l)  builtInDrop :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)] builtInDrop ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = case vl of@@ -380,10 +383,10 @@   TCList l -> pure $ Just $ ArrayValue (V.drop c l)  builtInArrayInsertLeft :: BuiltInFnWithDoc ['("item", Value), '("initial_list", Vector Value)]-builtInArrayInsertLeft ((coerce -> c) :> (coerce -> v1) :> _) = pure $ Just $ ArrayValue (V.cons c v1)+builtInArrayInsertLeft (!(coerce -> !c) :> !((DS.force . coerce) -> !v1) :> _) = pure $ v1 `seq` c `seq` Just $ ArrayValue (V.cons c v1)  builtInArrayInsertRight :: BuiltInFnWithDoc ['("initial_list", Vector Value), '("item", Value)]-builtInArrayInsertRight ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.snoc v1 c)+builtInArrayInsertRight (!((DS.force . coerce) -> !v1) :> !(coerce -> !c) :> _) = pure $ v1 `seq` c `seq` Just $ ArrayValue (V.snoc v1 c)  builtInHead :: BuiltInFnWithDoc '[ '("source_list", Vector Value)] builtInHead ((coerce -> v1) :> _) = case V.uncons v1 of@@ -509,8 +512,13 @@ consoleLog :: Text -> InterpretM () consoleLog msg = do   isLogChannel <$> getInterpretM >>= \case-    Just chan ->  liftIO $ atomically $ writeTChan chan msg-    Nothing -> pass+    SyncAutoRefresh chan ->  liftIO $ do+      atomically $ do+        writeTBQueue chan msg+      void $ iterateWhile id (atomically $ isFullTBQueue chan)+    AsyncDeferedRefresh chan ->  liftIO $+      atomically $ writeTBQueue chan msg+    NoLog -> pass  importModule :: FilePath -> InterpretM Value importModule filePath = do

@@ -9,6 +9,7 @@   ) where  import Common+import Control.DeepSeq import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar@@ -17,6 +18,7 @@ import Control.Monad.IO.Class import Control.Monad.Loops (iterateWhile) import Data.Bits+import GHC.Generics import Data.Constraint import Data.Kind (Type) import Data.Map.Strict as M hiding (keys)@@ -175,7 +177,7 @@           --     appendLog (oldLine, neLine)           --     else pass           A.setCursorPosition (idx + screenOffsetY) screenOffsetX-          -- mapM_ (\x -> do T.putStr x; S.hFlush S.stdout; wait 0.05;) (stRender <$> neLine)+          -- mapM_ (\x -> do T.putStr x; S.hFlush S.stdout; wait 0.005;) (stRender <$> neLine)           mapM_ T.putStr (stRender <$> neLine)           S.hFlush S.stdout         else pure ()@@ -375,13 +377,17 @@   | Fun Int   | Tab   | Return-  deriving (Show, Ord, Eq)+  deriving (Show, Ord, Eq, Generic) +instance NFData CtrlKey+ data KeyEvent   = KeyChar Bool Bool Bool Char -- Bool fields for modifiers for ctrl, shift, alt   | KeyCtrl Bool Bool Bool CtrlKey-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) +instance NFData KeyEvent+ data TerminalEvent   = TerminalKey KeyEvent   | TerminalResize Int Int@@ -493,6 +499,9 @@  data SomeWidgetRef where   SomeWidgetRef :: forall a. (Typeable a, Widget a) => WRef a -> SomeWidgetRef++instance NFData SomeWidgetRef where+  rnf _ = ()  instance Show SomeWidgetRef where   show _ = "(Widget)"

@@ -1,22 +1,34 @@ module UI.Widgets.LogWidget where  import Data.Text as T+import Data.Foldable+import qualified Data.Queue.Bounded as BQ import Common+import System.Console.ANSI (Color(..)) import UI.Widgets.Common as C-import UI.Widgets.Editor +import DiffRender.DiffRender++data LogEntry = LogEntry+  { leTimestamp :: Text+  , leLog :: Text+  }+ data LogWidget = LogWidget   { lwDim     :: Dimensions-  , lwContent :: [Text]+  , lwContent :: BQ.BQueue LogEntry   , lwPos     :: ScreenPos   , lwVisible :: Bool-  , lwContentWidget :: WRef EditorWidget   } +emptyLog :: WidgetC m => WRef LogWidget -> m ()+emptyLog ref =+  modifyWRef ref (\lw -> lw { lwContent = BQ.empty (diH $ lwDim lw) })+ insertLog :: WidgetC m => WRef LogWidget -> Text -> m () insertLog ref l = do   timestr <- liftIO getLocalTimeString-  modifyWRef ref (\lw -> lw { lwContent = Prelude.take 20 $ (timestr <> "| " <> l) : lwContent lw  })+  modifyWRef ref (\lw -> lw { lwContent = BQ.cons (LogEntry timestr l) (lwContent lw) })  instance Moveable LogWidget where   getPos ref = lwPos <$> readWRef ref@@ -25,8 +37,11 @@   getDim ref =     lwDim <$> readWRef ref   resize ref cb =-    modifyWRef ref (\ww -> ww { lwDim = cb $ lwDim ww })+    modifyWRef ref (\ww -> let newDim = cb $ lwDim ww in  ww { lwDim = newDim, lwContent = resizeBq (diH newDim) (lwContent ww) }) +resizeBq :: Int -> BQ.BQueue a -> BQ.BQueue a+resizeBq l q = BQ.fromList l $ toList $ q+ instance Widget LogWidget where   hasCapability (MoveableCap _)  = Just Dict   hasCapability (DrawableCap _)  = Just Dict@@ -40,22 +55,27 @@     case lwVisible w of       False -> pure ()       True -> do-        move (lwContentWidget w) (lwPos w)-        resize (lwContentWidget w) (\_ -> (lwDim w))-        setContent (lwContentWidget w) (T.intercalate "\n" (Prelude.reverse $ lwContent w))-        scrollToBottom (lwContentWidget w)-        draw (lwContentWidget w)+        forM_ (Prelude.zip [0 .. (diH (lwDim w) - 1)] (toList $ BQ.reverse $ lwContent w)) $ \(offset, li) -> do+          let startPos = (moveDown offset $ lwPos w)+          wSetCursor startPos+          csPutText $ StyledText (Fg Magenta) [Plain $ leTimestamp li, Plain ": "]+          let timeStampOffset = (T.length $ leTimestamp li) + 2+          wSetCursor (moveRight timeStampOffset startPos)+          let+            containableLength = diW (lwDim w) - timeStampOffset+            logContent = leLog li+            content = if T.length logContent > containableLength+              then T.take (containableLength - 2) logContent <> ".."+              else logContent+          csPutText $ StyledText (Fg Green) [Plain content]  logWidget   :: forall m. WidgetC m => m (WRef LogWidget) logWidget = do-  ew <- editor (\_ -> pure []) Nothing-  modifyWRef ew (\ew' -> ew' { ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }})   newWRef $     LogWidget     { lwDim = Dimensions 10 10-    , lwContent = []+    , lwContent = BQ.empty 10     , lwPos = ScreenPos 0 0     , lwVisible = True-    , lwContentWidget = ew     }

@@ -51,4 +51,4 @@     interpret'' = interpret id Nothing  ensureVarIs :: ScopeKey -> Value -> InterpreterState -> Expectation-ensureVarIs sk v (isGlobalScope -> scope) = (lookupInTopScope sk [scope]) `shouldBe` (Just v)+ensureVarIs sk v (isModuleScope -> scope) = (lookupInTopScope sk scope) `shouldBe` (Just v)