diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/docs/functions/concurrency.md b/docs/functions/concurrency.md --- a/docs/functions/concurrency.md +++ b/docs/functions/concurrency.md @@ -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 diff --git a/samples/factorial-recursive.spd b/samples/factorial-recursive.spd new file mode 100644 --- /dev/null +++ b/samples/factorial-recursive.spd @@ -0,0 +1,8 @@ +proc fact(n) + if (n == 1) then + return 1 + else + return (n * fact((n - 1))) + endif +endproc +println(fact(10000)) diff --git a/samples/fib-cache.spd b/samples/fib-cache.spd new file mode 100644 --- /dev/null +++ b/samples/fib-cache.spd @@ -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)) diff --git a/samples/fib-generator.spd b/samples/fib-generator.spd new file mode 100644 --- /dev/null +++ b/samples/fib-generator.spd @@ -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 diff --git a/spade.cabal b/spade.cabal --- a/spade.cabal +++ b/spade.cabal @@ -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 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -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) diff --git a/src/Compiler/AST/Expression.hs b/src/Compiler/AST/Expression.hs --- a/src/Compiler/AST/Expression.hs +++ b/src/Compiler/AST/Expression.hs @@ -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 diff --git a/src/Compiler/AST/FunctionDef.hs b/src/Compiler/AST/FunctionDef.hs --- a/src/Compiler/AST/FunctionDef.hs +++ b/src/Compiler/AST/FunctionDef.hs @@ -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 diff --git a/src/Compiler/AST/FunctionStatement.hs b/src/Compiler/AST/FunctionStatement.hs --- a/src/Compiler/AST/FunctionStatement.hs +++ b/src/Compiler/AST/FunctionStatement.hs @@ -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 diff --git a/src/Compiler/AST/Parser/Common.hs b/src/Compiler/AST/Parser/Common.hs --- a/src/Compiler/AST/Parser/Common.hs +++ b/src/Compiler/AST/Parser/Common.hs @@ -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 == [] diff --git a/src/Compiler/Lexer/Comments.hs b/src/Compiler/Lexer/Comments.hs --- a/src/Compiler/Lexer/Comments.hs +++ b/src/Compiler/Lexer/Comments.hs @@ -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 = "-- " diff --git a/src/Compiler/Lexer/Identifiers.hs b/src/Compiler/Lexer/Identifiers.hs --- a/src/Compiler/Lexer/Identifiers.hs +++ b/src/Compiler/Lexer/Identifiers.hs @@ -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 diff --git a/src/Compiler/Lexer/Literals.hs b/src/Compiler/Lexer/Literals.hs --- a/src/Compiler/Lexer/Literals.hs +++ b/src/Compiler/Lexer/Literals.hs @@ -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 diff --git a/src/Compiler/Lexer/Operators.hs b/src/Compiler/Lexer/Operators.hs --- a/src/Compiler/Lexer/Operators.hs +++ b/src/Compiler/Lexer/Operators.hs @@ -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 diff --git a/src/IDE/IDE.hs b/src/IDE/IDE.hs --- a/src/IDE/IDE.hs +++ b/src/IDE/IDE.hs @@ -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 diff --git a/src/Interpreter/Common.hs b/src/Interpreter/Common.hs --- a/src/Interpreter/Common.hs +++ b/src/Interpreter/Common.hs @@ -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 diff --git a/src/Interpreter/Interpreter.hs b/src/Interpreter/Interpreter.hs --- a/src/Interpreter/Interpreter.hs +++ b/src/Interpreter/Interpreter.hs @@ -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) diff --git a/src/Interpreter/Lib/Misc.hs b/src/Interpreter/Lib/Misc.hs --- a/src/Interpreter/Lib/Misc.hs +++ b/src/Interpreter/Lib/Misc.hs @@ -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 diff --git a/src/UI/Widgets/Common.hs b/src/UI/Widgets/Common.hs --- a/src/UI/Widgets/Common.hs +++ b/src/UI/Widgets/Common.hs @@ -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)" diff --git a/src/UI/Widgets/LogWidget.hs b/src/UI/Widgets/LogWidget.hs --- a/src/UI/Widgets/LogWidget.hs +++ b/src/UI/Widgets/LogWidget.hs @@ -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 } diff --git a/test/Interpreter/InterpreterSpec.hs b/test/Interpreter/InterpreterSpec.hs --- a/test/Interpreter/InterpreterSpec.hs +++ b/test/Interpreter/InterpreterSpec.hs @@ -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)