spade (empty) → 0.1.0.0
raw patch · 69 files changed
+7579/−0 lines, 69 filesdep +Decimaldep +WAVEdep +Win32setup-changed
Dependencies added: Decimal, WAVE, Win32, aeson, ansi-terminal, base, bytestring, constraints, containers, exceptions, file-embed, hedgehog, hex-text, hspec, hspec-discover, hspec-hedgehog, monad-loops, mtl, neat-interpolation, ordered-containers, process, random, scientific, sdl2, sdl2-mixer, spade, stm, strip-ansi-escape, template-haskell, text, time, unordered-containers, vector, vty
Files
- ChangeLog.md +3/−0
- README.md +74/−0
- Setup.hs +2/−0
- app/Main.hs +52/−0
- spade.cabal +361/−0
- src/Common.hs +258/−0
- src/Compiler/AST.hs +11/−0
- src/Compiler/AST/Common.hs +117/−0
- src/Compiler/AST/Expression.hs +329/−0
- src/Compiler/AST/FunctionDef.hs +39/−0
- src/Compiler/AST/FunctionStatement.hs +243/−0
- src/Compiler/AST/Parser/Common.hs +44/−0
- src/Compiler/AST/Program.hs +48/−0
- src/Compiler/Lexer.hs +17/−0
- src/Compiler/Lexer/Comments.hs +28/−0
- src/Compiler/Lexer/Delimeters.hs +48/−0
- src/Compiler/Lexer/Identifiers.hs +33/−0
- src/Compiler/Lexer/Keywords.hs +106/−0
- src/Compiler/Lexer/Literals.hs +87/−0
- src/Compiler/Lexer/Operators.hs +57/−0
- src/Compiler/Lexer/Tokens.hs +118/−0
- src/Compiler/Lexer/Whitespaces.hs +38/−0
- src/Compiler/Parser.hs +36/−0
- src/Highlighter/Highlighter.hs +17/−0
- src/IDE/Common.hs +30/−0
- src/IDE/Help.hs +317/−0
- src/IDE/Help/Contents.hs +12/−0
- src/IDE/Help/Parser.hs +193/−0
- src/IDE/IDE.hs +599/−0
- src/Interpreter.hs +62/−0
- src/Interpreter/Common.hs +556/−0
- src/Interpreter/Initialize.hs +123/−0
- src/Interpreter/Interpreter.hs +366/−0
- src/Interpreter/Lib/Concurrency.hs +79/−0
- src/Interpreter/Lib/Math.hs +58/−0
- src/Interpreter/Lib/Misc.hs +234/−0
- src/Interpreter/Lib/SDL.hs +310/−0
- src/Parser.hs +8/−0
- src/Parser/Lib.hs +101/−0
- src/Parser/Parser.hs +158/−0
- src/Test.hs +24/−0
- src/Test/Common.hs +23/−0
- src/UI/Chars.hs +21/−0
- src/UI/Terminal/IO.hs +23/−0
- src/UI/Widgets.hs +14/−0
- src/UI/Widgets/AutoComplete.hs +99/−0
- src/UI/Widgets/BorderBox.hs +56/−0
- src/UI/Widgets/Common.hs +455/−0
- src/UI/Widgets/Editor.hs +571/−0
- src/UI/Widgets/Editor/Cursor.hs +70/−0
- src/UI/Widgets/Layout.hs +138/−0
- src/UI/Widgets/LogWidget.hs +81/−0
- src/UI/Widgets/MenuContainer.hs +107/−0
- src/UI/Widgets/NullWidget.hs +25/−0
- src/UI/Widgets/TextContainer.hs +50/−0
- src/UI/Widgets/WatchWidget.hs +59/−0
- test/Common.hs +33/−0
- test/Compiler/AST/ParserSpec.hs +11/−0
- test/Compiler/Lexer/CommentsSpec.hs +18/−0
- test/Compiler/Lexer/DelimeterSpec.hs +9/−0
- test/Compiler/Lexer/IdentifierSpec.hs +9/−0
- test/Compiler/Lexer/KeywordSpec.hs +9/−0
- test/Compiler/Lexer/LiteralSpec.hs +26/−0
- test/Compiler/Lexer/OperatorSpec.hs +9/−0
- test/Compiler/Lexer/TokenSpec.hs +9/−0
- test/Interpreter/InterpreterSpec.hs +55/−0
- test/Spec.hs +1/−0
- test/UI/EditorSpec.hs +185/−0
- test/UI/WidgetSpec.hs +17/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for S.P.A.D.E++## Unreleased changes
+ README.md view
@@ -0,0 +1,74 @@+# S.P.A.D.E++S.P.A.D.E stands of Simple Programming And Debugging Environment.++It contains a simple programming language and a built-in Terminal based+IDE.++The following is a small spade program that draws a bunch of random circles+in red color, in an SDL window.++```+graphicswindow(400, 400, true)+setcolor(255, 0, 0)+for i = 1 to 100+ circle(random(10, 300), random(10, 300), random(10, 40))+endfor+drawscreen()+waitforkey()+```++The entire language and function reference is available in the IDE in an+easily searchable way. Press F1 or use the help menu to access it.++### IDE Demo+A small screen recording of SPADE in action can be seen here++[](https://asciinema.org/a/SM9tZ2ZiJofikPRxHCQyqDvRY)++### Installing++You can download the source package and use `stack` tool to build and install it.++After extracting the source to a folder, running the following command in the folder+should install it.++```+stack build && stack install++```++For the time being, this does not seem to build on Windows operating system.++### Getting started++The program should be started by providing a file name. For example,++```+spade /tmp/temp.spd+```++If the file does not exist, it will be created on save. If it exist then+contents will loaded into the editor.++Other than this are no provisions to select or open a file from within the IDE.+The user is supposed to only work with a single file at one time.++To interpret a spade program without starting the IDE, you can use+the `run` command.++```+spade run /tmp/temp.spd+```++Will execute the program without opening the IDE.++### Dependencies++To install depdendencies:++```+ apt-get install libsdl2-dev+ apt-get install libsdl2-mixer-dev+ apt-get install libtinfo-dev+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,52 @@+module Main where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Data.Text.IO as T+import System.Environment+import System.IO as SIO++import Compiler.Parser+import UI.Widgets.Common+import IDE.IDE+import Interpreter+import Interpreter.Common++data CommandLineOptions+ = StartIDE FilePath+ | RunProgram FilePath++getCommandLineOption :: IO CommandLineOptions+getCommandLineOption = do+ getArgs >>= \case+ ["run", filePath] -> pure $ RunProgram filePath+ [filePath] -> pure $ StartIDE filePath+ _ -> do+ error "Unrecognized cmd line arguments. Pass a file name (existing or new) to load the program in the IDE, or using 'spade run filename.spd' command to just run the program without starting the IDE."++main :: IO ()+main = do+ SIO.hSetEcho stdin False+ SIO.hSetBuffering stdin NoBuffering+ SIO.hSetBuffering stdout (BlockBuffering Nothing)++ vty <- initializeVty+ inputBroadcastChan <- liftIO newBroadcastTChanIO+ void $ forkIO $ forever $ do+ keys' <- readVtyEvent vty+ mapM (atomically . writeTChan inputBroadcastChan) keys'++ getCommandLineOption >>= \case+ RunProgram filePath -> do+ content <- T.readFile filePath+ program <- compile content+ inputChan <- liftIO $ atomically $ dupTChan inputBroadcastChan+ is <- interpret_ inputChan program+ tryTakeMVar (isDebugOut is) >>= \case+ Just (Errored t) -> T.putStrLn t+ _ -> pure ()++ StartIDE filePath -> runIDE filePath inputBroadcastChan+ liftIO $ shutdownVty vty
+ spade.cabal view
@@ -0,0 +1,361 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: spade+version: 0.1.0.0+synopsis: A simple programming and debugging environment.+description: A simple weakly typed, dynamic, interpreted programming langauge and terminal IDE.+category: language, interpreter, ide+author: Sandeep.C.R+maintainer: sandeep@sras.me+copyright: 2022 Sandeep.C.R+license: GPL-3.0-only+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++library+ exposed-modules:+ Common+ Compiler.AST+ Compiler.AST.Common+ Compiler.AST.Expression+ Compiler.AST.FunctionDef+ Compiler.AST.FunctionStatement+ Compiler.AST.Parser.Common+ Compiler.AST.Program+ Compiler.Lexer+ Compiler.Lexer.Comments+ Compiler.Lexer.Delimeters+ Compiler.Lexer.Identifiers+ Compiler.Lexer.Keywords+ Compiler.Lexer.Literals+ Compiler.Lexer.Operators+ Compiler.Lexer.Tokens+ Compiler.Lexer.Whitespaces+ Compiler.Parser+ Highlighter.Highlighter+ IDE.Common+ IDE.Help+ IDE.Help.Contents+ IDE.Help.Parser+ IDE.IDE+ Interpreter+ Interpreter.Common+ Interpreter.Initialize+ Interpreter.Interpreter+ Interpreter.Lib.Concurrency+ Interpreter.Lib.Math+ Interpreter.Lib.Misc+ Interpreter.Lib.SDL+ Parser+ Parser.Lib+ Parser.Parser+ Test+ Test.Common+ UI.Chars+ UI.Terminal.IO+ UI.Widgets+ UI.Widgets.AutoComplete+ UI.Widgets.BorderBox+ UI.Widgets.Common+ UI.Widgets.Editor+ UI.Widgets.Editor.Cursor+ UI.Widgets.Layout+ UI.Widgets.LogWidget+ UI.Widgets.MenuContainer+ UI.Widgets.NullWidget+ UI.Widgets.TextContainer+ UI.Widgets.WatchWidget+ other-modules:+ Paths_spade+ hs-source-dirs:+ src+ default-extensions:+ AllowAmbiguousTypes+ DeriveLift+ NumericUnderscores+ DerivingStrategies+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyCase+ FunctionalDependencies+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NegativeLiterals+ NumDecimals+ OverloadedLabels+ OverloadedStrings+ PatternSynonyms+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ImpredicativeTypes+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns+ PackageImports+ InstanceSigs+ build-depends:+ Decimal+ , WAVE+ , aeson+ , ansi-terminal+ , base >=4.9 && <5+ , bytestring+ , constraints+ , containers+ , exceptions+ , file-embed+ , hedgehog+ , hex-text+ , hspec+ , hspec-hedgehog+ , monad-loops+ , mtl+ , ordered-containers+ , process+ , random+ , scientific+ , sdl2+ , sdl2-mixer+ , stm+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector+ , vty+ if os(windows)+ ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults+ build-depends:+ Win32 >=2.10.0.1+ else+ ghc-options: -Wall -Wno-type-defaults+ default-language: Haskell2010+ autogen-modules: Paths_spade++executable spade+ main-is: Main.hs+ other-modules:+ Paths_spade+ hs-source-dirs:+ app+ default-extensions:+ AllowAmbiguousTypes+ DeriveLift+ NumericUnderscores+ DerivingStrategies+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyCase+ FunctionalDependencies+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NegativeLiterals+ NumDecimals+ OverloadedLabels+ OverloadedStrings+ PatternSynonyms+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ImpredicativeTypes+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns+ PackageImports+ InstanceSigs+ ghc-options: -threaded+ build-depends:+ Decimal+ , WAVE+ , aeson+ , ansi-terminal+ , base >=4.9 && <5+ , bytestring+ , constraints+ , containers+ , exceptions+ , file-embed+ , hedgehog+ , hex-text+ , hspec+ , hspec-hedgehog+ , monad-loops+ , mtl+ , ordered-containers+ , process+ , random+ , scientific+ , sdl2+ , sdl2-mixer+ , spade+ , stm+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector+ , vty+ if os(windows)+ ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults+ build-depends:+ Win32 >=2.10.0.1+ else+ ghc-options: -Wall -Wno-type-defaults+ default-language: Haskell2010+ autogen-modules: Paths_spade++test-suite spade-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Common+ Compiler.AST.ParserSpec+ Compiler.Lexer.CommentsSpec+ Compiler.Lexer.DelimeterSpec+ Compiler.Lexer.IdentifierSpec+ Compiler.Lexer.KeywordSpec+ Compiler.Lexer.LiteralSpec+ Compiler.Lexer.OperatorSpec+ Compiler.Lexer.TokenSpec+ Interpreter.InterpreterSpec+ UI.EditorSpec+ UI.WidgetSpec+ Paths_spade+ hs-source-dirs:+ test+ default-extensions:+ AllowAmbiguousTypes+ DeriveLift+ NumericUnderscores+ DerivingStrategies+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyCase+ FunctionalDependencies+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NegativeLiterals+ NumDecimals+ OverloadedLabels+ OverloadedStrings+ PatternSynonyms+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ImpredicativeTypes+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns+ PackageImports+ InstanceSigs+ build-depends:+ Decimal+ , WAVE+ , aeson+ , ansi-terminal+ , base >=4.9 && <5+ , bytestring+ , constraints+ , containers+ , exceptions+ , file-embed+ , hedgehog+ , hex-text+ , hspec+ , hspec-discover+ , hspec-hedgehog+ , monad-loops+ , mtl+ , neat-interpolation+ , ordered-containers+ , process+ , random+ , scientific+ , sdl2+ , sdl2-mixer+ , spade+ , stm+ , strip-ansi-escape+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector+ , vty+ if os(windows)+ ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults+ build-depends:+ Win32 >=2.10.0.1+ else+ ghc-options: -Wall -Wno-type-defaults+ default-language: Haskell2010
+ src/Common.hs view
@@ -0,0 +1,258 @@+module Common+ ( module Common+ , TH.Lift+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.List as DL+import Data.Text as T+import Data.Text.IO as T+import qualified Language.Haskell.TH.Syntax as TH+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..),+ SGR(..), Underlining(..), setSGRCode)+import Test.Common++class HReadable a where+ hReadable :: a -> Text++getTimestamp :: IO Int+getTimestamp = (round . (* 10e12)) <$> getPOSIXTime++wait :: Double -> IO ()+wait s = threadDelay (floor $ s * 1000_000)++origin :: ScreenPos+origin = ScreenPos 0 0++data Dimensions = Dimensions+ { diW :: Int+ , diH :: Int+ } deriving (Eq, Show)++amendHeight :: Dimensions -> (Int -> Int) -> Dimensions+amendHeight d fn = d { diH = fn $ diH d }++amendWidth :: Dimensions -> (Int -> Int) -> Dimensions+amendWidth d fn = d { diW = fn $ diW d }++moveLeft :: Int -> ScreenPos -> ScreenPos+moveLeft i d = d { sX = sX d - i }++moveRight :: Int -> ScreenPos -> ScreenPos+moveRight i d = d { sX = sX d + i }++moveUp :: Int -> ScreenPos -> ScreenPos+moveUp i d = d { sY = sY d - i }++moveDown :: Int -> ScreenPos -> ScreenPos+moveDown i d = d { sY = sY d + i }++addSp :: ScreenPos -> ScreenPos -> ScreenPos+addSp s1 s2 = ScreenPos (sX s1 + sX s2) (sY s1 + sY s2)++type IntType = Integer+type FloatType = Double++data Style = FgBg Color Color| Fg Color | Bg Color | TextUnderline | NoStyle+ deriving (Eq, Show)++data StyledText = StyledText Style [StyledText] | Plain Text+ deriving (Show, Eq)++renderLines :: [[StyledText]] -> Text+renderLines st = T.intercalate "\n" $ (\i -> (T.concat $ stRender <$> i)) <$> st++instance HasGen StyledText where+ getGen = recursive choice+ [Plain . T.pack <$> txGen]+ [StyledText NoStyle <$> list (linear 1 100) getGen]+ where+ txGen = list (linear 1 100) (choice [lower, upper])++-- Punch a hole starting from offset of size length. Columns start+-- from 0. Returns chunks left and right of the hole.+punchHole :: (Int, Int) -> [StyledText] -> ([StyledText], [StyledText])+punchHole (tk, ln) sts = (stTake tk sts, stDrop (tk + ln) sts)++stInsert :: [StyledText] -> Int -> StyledText -> [StyledText]+stInsert sts cx t =+ let (lr, rg) = punchHole (cx, stLength t) sts+ in (lr <> [t] <> rg)++stDrop :: Int -> [StyledText] -> [StyledText]+stDrop l stsIn = snd $ DL.foldl' stDrop' (l, []) stsIn+ where+ stDrop' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText])+ stDrop' (0, sts) st = (0, sts <> [st])+ stDrop' (s, sts) (Plain t) = let+ r = T.drop s t+ rlen = T.length r+ in if rlen > 0+ then (s - (T.length t - rlen), sts <> [Plain r])+ else (s - T.length t, sts)+ stDrop' (s, sts) (StyledText st sts') =+ case DL.foldl' stDrop' (s, []) sts' of+ (s', sts''@(_:_)) -> (s', sts <> [StyledText st sts''])+ (s', _) -> (s', sts)++stTake :: Int -> [StyledText] -> [StyledText]+stTake l stsIn = snd $ DL.foldl' stTake' (l, []) stsIn+ where+ stTake' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText])+ stTake' (0, sts) _ = (0, sts)+ stTake' (s, sts) (Plain t) = let+ r = T.take s t+ in (s - T.length r, sts <> [Plain r])+ stTake' (s, sts) (StyledText st sts') = let+ (s', sts'') = DL.foldl' stTake' (s, []) sts'+ in (s', sts <> [StyledText st sts''])++applyStyleToRange :: (StyledText -> StyledText) -> Int -> (Int, Int) -> [StyledText] -> [StyledText]+applyStyleToRange fn sStart (rStart, rEnd) segments =+ let+ sEnd = sStart + stTotalLength segments - 1+ in if rEnd >= sStart && rStart <= sEnd+ then+ let+ r1 = max 0 (rStart - sStart)+ r2 = rEnd - (max sStart rStart) + 1+ in (stTake r1 segments) <> (fn <$> (stTake r2 (stDrop r1 segments))) <> (stDrop (r1 + r2) segments)+ else segments++stLength :: StyledText -> Int+stLength (Plain t) = T.length t+stLength (StyledText _ sts) = sum (stLength <$> sts)++stTotalLength :: [StyledText] -> Int+stTotalLength sts = sum $ stLength <$> sts++-- This implimentation is not optimal and does not correctly+-- render nested styles. But this appear to be good enough for now.+styleToPrefix :: Style -> Text+styleToPrefix st = T.pack $ case st of+ FgBg fg bg -> setSGRCode [SetColor Foreground Vivid fg] <> setSGRCode [SetColor Background Vivid bg]+ Bg bg -> setSGRCode [SetColor Background Vivid bg]+ Fg fg -> setSGRCode [SetColor Foreground Vivid fg]+ TextUnderline -> setSGRCode [SetUnderlining SingleUnderline]+ NoStyle -> mempty++stRender :: StyledText -> Text+stRender st = stRender' NoStyle st++mergeStyles :: Style -> Style -> Style+mergeStyles NoStyle a = a+mergeStyles a NoStyle = a+mergeStyles (Fg a) (Bg b) = (FgBg a b)+mergeStyles (Bg a) (Fg b) = (FgBg b a)+mergeStyles _ a = a++stRender' :: Style -> StyledText -> Text+stRender' _ (Plain t) = T.replace "\n" " " t+stRender' pst (StyledText st sts) = let+ suffix = T.pack $ setSGRCode []+ prefix = styleToPrefix (mergeStyles pst st)+ in T.concat (((\x -> prefix <> x <> suffix) . stRender' st) <$> sts)++data ScreenPos = ScreenPos { sX :: Int, sY :: Int }+ deriving (Eq, Ord, Show)++type CursorInfo = (ScreenPos, CursorStyle)++emptyCursorInfo :: CursorInfo+emptyCursorInfo = (origin, Bar)++pass :: Monad m => m ()+pass = pure ()++data CursorStyle+ = Bar+ | Underline+ | Hidden+ deriving (Eq, Show)++class HasEmpty s where+ isEmpty :: s -> Bool++class HasLog m where+ appendLog :: Show a => a -> m ()++class ToSource a where+ toSource :: a -> Text+ toSourcePretty :: Int -> a -> Text+ toSource a = toSourcePretty 0 a+ toSourcePretty _ a = toSource a++instance ToSource a => ToSource [a] where+ toSourcePretty i fss = T.intercalate "\n" (toSourcePretty i <$> fss)++instance ToSource a => ToSource (Maybe a) where+ toSourcePretty i (Just x) = toSourcePretty i x+ toSourcePretty _ Nothing = mempty++instance ToSource Text where+ toSource = id++indent :: Int -> Text+indent i = T.replicate i " "++instance HasLog IO where+ appendLog a = void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n"))++-- Mostly for use with highlighting and not actual token parsing.+-- This represent any tokens we want to show in editors with highlighting.+class Highlightable a where+ getTokenLoc :: a -> Location+ highlight :: (StyledText, Maybe a) -> StyledText+ pairWithTokens :: [a] -> Int -> Text -> ([(Text, Maybe a)], [a])+ -- ^ Associate token type with their text sources+ -- First arg is stack of tokens at current location+ -- Second arg is the text offset at current location+ -- Third arg is the text at the current location+ --+ -- This is so that in an editor, a line of text can break at somewhere in the+ -- middle of a single token. So an editor cannot display tokenwise without more+ -- complex tracking of current offset in source text.++instance Highlightable Text where+ highlight (x, _) = x+ pairWithTokens _ _ t = ([(t, Nothing)], [])+ getTokenLoc = error "No token location for text"++genericPairWithTokens :: (a -> Int) -> (a -> Location) -> Int -> Text -> [a] -> ([(Text, Maybe a)], [a])+genericPairWithTokens _ _ _ "" [] = ([], [])+genericPairWithTokens _ _ _ src [] = ([(src, Nothing)], [])+genericPairWithTokens getOffsetEnd getLoc offset src ti@(tk:rst)+ | src == "" = ([], ti)+ | (lcOffset (getLoc tk)) > offset = let+ tokenLen = (getOffsetEnd tk) - offset + 1+ frag = T.take tokenLen src+ (fragRst, ts) = genericPairWithTokens getOffsetEnd getLoc (offset+tokenLen) (T.drop tokenLen src) ti+ in ((frag, Just tk): fragRst, ts)+ | (lcOffset (getLoc tk)) <= offset = let+ tokenLen = (getOffsetEnd tk) - offset + 1+ frag = T.take tokenLen src+ rst' = if (getOffsetEnd tk) > (offset + T.length src - 1) then ti else rst+ (fragRst, ts) = genericPairWithTokens getOffsetEnd getLoc (offset+tokenLen) (T.drop tokenLen src) rst'+ in ((frag, Just tk): fragRst, ts)+ | otherwise = ([], ti)++data Location = Location { lcLine :: Int, lcColumn :: Int, lcOffset :: Int }+ deriving (TH.Lift, Show, Eq)++instance HReadable Location where+ hReadable l = T.pack $ "Line: " <> (show (lcLine l)) <> " Column: " <> show (lcColumn l) <> " Offset: " <> show (lcOffset l)++emptyLocation :: Location+emptyLocation = Location 1 1 0++toInt :: IntType -> Int+toInt x = if x > fromIntegral (maxBound @Int) then error "Int conversion out of bound" else fromIntegral x++safeIndex :: [a] -> Int -> Maybe a+safeIndex l i = fst $ DL.foldl' fn (Nothing, 0) l+ where+ fn (Just x, ci) _ = (Just x, ci)+ fn (Nothing, ci) a = if ci == i then (Just a, ci) else (Nothing, ci+1)
+ src/Compiler/AST.hs view
@@ -0,0 +1,11 @@+module Compiler.AST+ ( module Expression+ , module FunctionDef+ , module FunctionStatement+ , module Program+ ) where++import Compiler.AST.Expression as Expression+import Compiler.AST.FunctionDef as FunctionDef+import Compiler.AST.FunctionStatement as FunctionStatement+import Compiler.AST.Program as Program
+ src/Compiler/AST/Common.hs view
@@ -0,0 +1,117 @@+module Compiler.AST.Common where++import Common+import Control.Applicative+import Control.Monad+import Data.List.NonEmpty as NE+import Data.Text++import Compiler.AST.Parser.Common+import Compiler.Lexer+import Compiler.Lexer.Comments+import Parser+import Test.Common++parseComment :: AstParser Comment+parseComment = parseToken "comment" (\case+ TkComment c -> Just c+ _ -> Nothing)++parseToken :: Text -> (TokenRaw -> Maybe a) -> AstParser a+parseToken name fn = ParserM name $ liftModifier $ \s -> case s of+ ((Token tr _ _) : rst) -> pure $ case fn tr of+ Just a -> (Right a, rst)+ Nothing -> (Left CantHandle, s)+ _ -> pure (Left CantHandle, s)++parseIdentifier :: AstParser Identifier+parseIdentifier = parseToken "Identifier" (\case+ TkIdentifier i -> Just i+ _ -> Nothing)++parseDelimeter :: Delimeter -> AstParser Delimeter+parseDelimeter dl = parseToken (toSource dl) (\case+ TkDelimeter l -> if l == dl then Just l else Nothing+ _ -> Nothing)++parseKeyword :: Keyword -> AstParser Keyword+parseKeyword kw = parseToken (toSource kw) (\case+ TkKeyword k -> if kw == k then Just k else Nothing+ _ -> Nothing)++parseOperator :: AstParser Operator+parseOperator = parseToken "Operator" (\case+ TkOperator k -> Just k+ _ -> Nothing)++parseOperator' :: Operator -> AstParser ()+parseOperator' op = parseToken "Operator" (\case+ TkOperator k -> if k == op then Just () else Nothing+ _ -> Nothing)++mandatoryNewline :: AstParser ()+mandatoryNewline = parseToken "NL" (\case+ TkWhitespace (NewLine _) -> Just ()+ _ -> Nothing)++whitespace :: AstParser ()+whitespace = void $ optional $ parseToken "WS" (\case+ TkWhitespace (Space _) -> Just ()+ TkWhitespace (Tab _) -> Just ()+ _ -> Nothing)++whitespaceNL :: AstParser ()+whitespaceNL = void $ optional $ parseToken "NL" (\case+ TkWhitespace (NewLine _) -> Just ()+ _ -> Nothing)++surroundWs :: AstParser a -> AstParser a+surroundWs p@(ParserM name _) = nameParser (name <> " surrounded by WS or NL ") $ do+ whitespaceOrNl+ a <- p+ whitespaceOrNl+ pure a++whitespaceOrNl :: AstParser ()+whitespaceOrNl = void $ many $ parseToken "WS" (\case+ TkWhitespace (Space _) -> Just ()+ TkWhitespace (Tab _) -> Just ()+ TkWhitespace (NewLine _) -> Just ()+ _ -> Nothing)++surroundWs_ :: AstParser a -> AstParser ()+surroundWs_ p@(ParserM name _) = nameParser (name <> " surrounded by WS") $ void $ surroundWs p++mandatory :: AstParser a -> AstParser a+mandatory (ParserM name fn) = ParserM ("mandatory " <> name) $ \s -> do+ case (astInput s) of+ [] -> pure (Left $ FatalError $ CustomError $ "Expecting " <> name <> " but ran out of input ", s)+ _ -> fn s >>= \case+ r@(Right _, _) -> pure r+ (Left fe@(FatalError _), _) -> pure (Left fe, s)+ (Left fe@(FatalErrorWithLocation _ _), _) -> pure (Left fe, s)+ (Left e, s'') -> case astInput s'' of+ [] -> pure (Left e, s)+ (h: _) -> pure (Left $ FatalErrorWithLocation (tkLocation h) $ CustomError $ "Expecting " <> name <> " but got " <> (pack $ show h), s)++nonEmptyGen :: Gen a -> Gen (NonEmpty a)+nonEmptyGen p = do h <- p; t <- list (linear 0 3) p; pure (h :| t)++wst :: Text+wst = toSource $ TkWhitespace (Space 1)++nlt :: Text+nlt = toSource $ TkWhitespace (NewLine 1)++parseItemListInParen :: AstParser a -> AstParser (Maybe (NonEmpty a))+parseItemListInParen itemParser = do+ surroundWs_ (parseDelimeter DlParenOpen)+ args <- optional itemParser >>= \case+ Just argHead -> do+ argsTail <- many $ do+ surroundWs_ $ parseDelimeter DlComma+ itemParser+ pure $ Just (argHead :| argsTail)+ Nothing -> pure Nothing+ surroundWs_ (parseDelimeter DlParenClose)+ pure args
+ src/Compiler/AST/Expression.hs view
@@ -0,0 +1,329 @@+module Compiler.AST.Expression where++import Control.Applicative+import Control.Monad+import Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Maybe hiding (maybe)+import Data.Text as T++import Common+import Compiler.AST.Common+import Compiler.AST.Parser.Common+import Compiler.Lexer+import Parser.Lib+import Parser.Parser+import Test.Common as C++-- This is only used to modify nested bindings in a+-- let statement, and is not actually a part of the expression.+data Subscript+ = SubscriptExpr Subscript ExpressionWithLoc+ | PropertySubscript Subscript Identifier+ | NoSubscript Identifier+ deriving (Eq, Show)++instance ToSource Subscript where+ toSource = \case+ SubscriptExpr sub i -> T.concat [toSource sub, "[", toSource i, "]"]+ PropertySubscript sub i -> T.concat [toSource sub, ".", toSource i]+ NoSubscript i -> toSource i++instance HasGen Subscript where+ getGen = recursive choice [NoSubscript <$> getGen]+ [ SubscriptExpr <$> getGen <*> getGen+ , PropertySubscript <$> getGen <*> getGen+ ]++data LiteralExpression+ = LAtomic Literal+ | LArray [ExpressionWithLoc]+ | LObject (Map.Map Text ExpressionWithLoc)+ deriving (Eq, Show)++instance ToSource LiteralExpression where+ toSource (LAtomic l) = toSource l+ toSource (LArray l) = T.concat ["[", T.intercalate ", " (toSource <$> l), "]"]+ toSource (LObject l) = T.concat ["{", T.intercalate ", " (toSource' <$> Map.toList l), "}"]+ where+ toSource' (x, y) = T.concat [toSource x, ": ", toSource y]++instance HasGen LiteralExpression where+ getGen = choice+ [ LAtomic <$> getGen+ , LArray <$> getGen+ , LObject <$> (Map.fromList <$> list (linear 1 2) (do a <- (text (linear 1 50) (enum 'a' 'z')); b <- getGen; pure ("key"<>a, b)))+ ]++data SubscriptedExpression+ = EArraySubscript ExpressionWithLoc ExpressionWithLoc+ | EPropertySubscript ExpressionWithLoc Identifier+ deriving (Show, Eq)++instance ToSource SubscriptedExpression where+ toSource = \case+ EArraySubscript sub i -> T.concat [toSource sub, "[", toSource i, "]"]+ EPropertySubscript sub i -> T.concat [toSource sub, ".", toSource i]++instance HasGen SubscriptedExpression where+ getGen = choice+ [ EArraySubscript <$> getGen <*> getGen+ , EPropertySubscript <$> getGen <*> getGen+ ]++data ExpressionWithLoc = ExpressionWithLoc { elExpression :: Expression, elLocation :: Location }+ deriving (Show)++instance Eq ExpressionWithLoc where+ (ExpressionWithLoc e1 _) == (ExpressionWithLoc e2 _) = e1 == e2++instance ToSource ExpressionWithLoc where+ toSource (ExpressionWithLoc e1 _) = toSource e1++data Expression+ = ELiteral LiteralExpression+ | EVar Identifier+ | ESubscripted SubscriptedExpression+ | EOperator Operator ExpressionWithLoc ExpressionWithLoc+ | ECall Identifier [ExpressionWithLoc] Bool -- Boolean is used during execution to mark tail calls+ | EConditional ExpressionWithLoc ExpressionWithLoc ExpressionWithLoc+ | EParan ExpressionWithLoc+ | EUnnamedFn (Maybe (NonEmpty Identifier)) ExpressionWithLoc+ | ENegated ExpressionWithLoc+ deriving (Show)++instance Eq Expression where -- Specialized implementation to implement equality for EParen wrapped expressions+ (ELiteral l1) == (ELiteral l2) = l1 == l2+ (EVar l1) == (EVar l2) = l1 == l2+ (ESubscripted l1) == (ESubscripted l2) = l1 == l2+ (EOperator o ex1 ex2) == (EOperator o1 ex3 ex4) = (o == o1) && (ex1 == ex3) && (ex2 == ex4)+ (ECall idef args _) == (ECall idef1 args2 _) = idef == idef1 && (args == args2)+ (EConditional ex1 ex2 ex3) == (EConditional ex4 ex5 ex6) = (ex1 == ex4) && (ex2 == ex5) && (ex3 == ex6)+ (EUnnamedFn args2 ex2) == (EUnnamedFn args3 ex3) = (args2 == args3) && (ex2 == ex3)+ (EParan ex1) == (EParan ex2) = ex1 == ex2+ (EParan ex1) == ex2 = (elExpression ex1) == ex2+ ex1 == (EParan ex2) = ex1 == (elExpression ex2)+ _ == _ = False++instance ToSource Expression where+ toSource = \case+ ELiteral l -> toSource l+ ENegated l -> toSource OpMinus <> toSource l+ EVar subscript -> toSource subscript+ ESubscripted subscript -> toSource subscript+ EOperator op exp1 exp2 -> T.concat [pOpen, toSource exp1, ws, toSource op, ws, toSource exp2, pClose]+ ECall i args _ -> T.concat $ [toSource i, toSource DlParenOpen] <> [T.intercalate ", " (toSource <$> args)] <> [toSource DlParenClose]+ EConditional bexp exp1 exp2 -> T.concat+ [ pOpen+ , toSource KwIf+ , ws+ , toSource DlParenOpen+ , toSource bexp+ , toSource DlParenClose+ , ws+ , toSource KwThen+ , ws+ , toSource exp1+ , ws+ , toSource KwElse+ , ws+ , toSource exp2+ , pClose+ ]+ EParan exp1 -> T.concat [toSource exp1]+ EUnnamedFn args expr ->+ let+ argsSrc = case args of+ Just args' -> T.intercalate ", " (toSource <$> (NE.toList args'))+ Nothing -> ""+ in T.concat [toSource KwFn, ws, toSource DlParenOpen, argsSrc, toSource DlParenClose, ws, toSource expr, ws, toSource KwEndFn]++ where+ ws = toSource (Space 1)+ pOpen = toSource DlParenOpen+ pClose = toSource DlParenClose++instance HasGen ExpressionWithLoc where+ getGen = ExpressionWithLoc <$> getGen <*> (pure emptyLocation)++instance HasGen Expression where+ getGen = recursive choice+ [ ELiteral <$> getGen+ , EVar <$> getGen+ , ESubscripted <$> getGen+ ]+ [ EOperator <$> getGen <*> getGen <*> getGen+ , ECall <$> getGen <*> (list (linear 1 2) getGen) <*> (pure False)+ , EConditional <$> getGen <*> getGen <*> getGen+ , EParan <$> getGen+ , EUnnamedFn <$> (C.maybe (nonEmptyGen getGen)) <*> getGen+ ]++addLRecursion :: ExpressionWithLoc -> AstParser ExpressionWithLoc+addLRecursion exp0 = do+ exp1 <- (parseAnyDots exp0) <|> (pure exp0)+ exp2 <- (parseAnySubscripts exp1) <|> (pure exp1)+ ((precedenceSort <$> (operatorParser exp2)) <|> (pure exp2))++parseAnyDots :: ExpressionWithLoc -> AstParser ExpressionWithLoc+parseAnyDots exp0 = do+ surroundWs_ (parseDelimeter DlPeriod)+ idf <- mandatory parseIdentifier+ addLRecursion (ExpressionWithLoc (ESubscripted (EPropertySubscript exp0 idf)) (elLocation exp0))++parseAnySubscripts :: ExpressionWithLoc -> AstParser ExpressionWithLoc+parseAnySubscripts exp0 = do+ surroundWs_ (parseDelimeter DlSquareParenOpen)+ indexExpr <- mandatory (astParser @ExpressionWithLoc)+ surroundWs_ (parseDelimeter DlSquareParenClose)+ addLRecursion (ExpressionWithLoc (ESubscripted (EArraySubscript exp0 indexExpr)) (elLocation exp0))++instance HasAstParser Expression where+ astParser = nameParser "Expression" $ elExpression <$> astParser++instance HasAstParser ExpressionWithLoc where+ astParser = nameParser "ExpressionWithLoc" $ do+ loc <- getParserLocation+ expr <- parserWithoutLR+ addLRecursion (ExpressionWithLoc expr loc)+ where+ parserWithoutLR+ = literalParser+ <|> unnamedFnParser+ <|> callParser+ <|> varParser+ <|> conditionalParser+ <|> parenthesisParser+ <|> negatedExpressionParser++unnamedFnParser :: AstParser Expression+unnamedFnParser = surroundWs $ do+ surroundWs_ (parseKeyword KwFn)+ args <- parseItemListInParen parseIdentifier+ expr <- mandatory (surroundWs (astParser @ExpressionWithLoc))+ mandatory $ surroundWs_ $ parseKeyword KwEndFn+ pure $ EUnnamedFn args expr++parenthesisParser :: AstParser Expression+parenthesisParser = surroundWs $ do+ void $ parseDelimeter DlParenOpen+ expr <- surroundWs (mandatory (astParser @ExpressionWithLoc))+ void $ mandatory (parseDelimeter DlParenClose)+ pure $ EParan expr++negatedExpressionParser :: AstParser Expression+negatedExpressionParser = surroundWs $ do+ parseOperator >>= \case+ OpMinus -> do+ e <- (mandatory (astParser @ExpressionWithLoc))+ pure $ ENegated e+ _ -> cantHandle++literalParser :: AstParser Expression+literalParser = ELiteral <$> (atomicLiteralParser <|> arrayLiteralParser <|> objectLiteralParser)++atomicLiteralParser :: AstParser LiteralExpression+atomicLiteralParser = surroundWs $ do+ l <- parseToken "Atomic Literal" (\case+ TkLiteral l -> Just l+ _ -> Nothing)+ pure $ LAtomic l++arrayLiteralParser :: AstParser LiteralExpression+arrayLiteralParser = do+ let itemParser = astParser @ExpressionWithLoc+ surroundWs_ (parseDelimeter DlSquareParenOpen)+ args <- optional itemParser >>= \case+ Just argHead -> do+ argsTail <- many $ do+ surroundWs_ $ parseDelimeter DlComma+ mandatory itemParser+ pure (argHead : argsTail)+ Nothing -> pure []+ surroundWs_ $ mandatory (parseDelimeter DlSquareParenClose)+ pure $ LArray args++objectLiteralParser :: AstParser LiteralExpression+objectLiteralParser = do+ let mapKeyParser = (unIdentifer <$> parseIdentifier) <|> (parseToken "Map key" $ \case+ TkLiteral (LitString t) -> Just t+ _ -> Nothing)+ let itemParser = do+ key <- mapKeyParser+ surroundWs_ $ mandatory $ nameParser "Colon" $ parseDelimeter DlColon+ expr <- mandatory (astParser @ExpressionWithLoc)+ pure (key, expr)+ surroundWs_ (parseDelimeter DlBraceParenOpen)+ args <- optional itemParser >>= \case+ Just argHead -> do+ argsTail <- many $ do+ surroundWs_ $ parseDelimeter DlComma+ mandatory itemParser+ pure (argHead : argsTail)+ Nothing -> pure []+ surroundWs_ (mandatory $ parseDelimeter DlBraceParenClose)+ pure $ LObject $ Map.fromList args++parseSubscript :: AstParser Subscript+parseSubscript = (NoSubscript <$> parseIdentifier) >>= parseSubscript'++parseSubscript' :: Subscript -> AstParser Subscript+parseSubscript' subin =+ optional (parseKeySubscript subin <|> parsePropertySubscript subin) >>= \case+ Just x -> pure x+ Nothing -> pure subin++parsePropertySubscript :: Subscript -> AstParser Subscript+parsePropertySubscript subin = do+ whitespaceOrNl+ void $ parseDelimeter DlPeriod+ identi <- mandatory $ surroundWs parseIdentifier+ parseSubscript' (PropertySubscript subin identi)++parseKeySubscript :: Subscript -> AstParser Subscript+parseKeySubscript subin = do+ whitespaceOrNl+ void $ parseDelimeter DlSquareParenOpen+ s <- mandatory $ surroundWs (astParser @ExpressionWithLoc)+ void $ parseDelimeter DlSquareParenClose+ parseSubscript' (SubscriptExpr subin s)++varParser :: AstParser Expression+varParser = nameParser "Variable" $ surroundWs (EVar <$> parseIdentifier)++callParser :: AstParser Expression+callParser = do+ (idf, args) <- callParser_+ pure $ ECall idf args False++callParser_ :: AstParser (Identifier, [ExpressionWithLoc])+callParser_ = surroundWs $ do+ idf <- parseIdentifier+ margs <- parseItemListInParen (astParser @ExpressionWithLoc)+ pure (idf, fromMaybe [] (NE.toList <$> margs))++conditionalParser :: AstParser Expression+conditionalParser = surroundWs $ do+ _ <- parseKeyword KwIf+ whitespace+ boolExp <- mandatory (astParser @ExpressionWithLoc)+ surroundWs_ $ mandatory (parseKeyword KwThen)+ exp1 <- mandatory (astParser @ExpressionWithLoc)+ surroundWs_ $ mandatory (parseKeyword KwElse)+ exp2 <- mandatory (astParser @ExpressionWithLoc)+ pure $ EConditional boolExp exp1 exp2++operatorParser :: ExpressionWithLoc -> AstParser ExpressionWithLoc+operatorParser lexp = surroundWs $ do+ optional parseOperator >>= \case+ Just operator -> do+ rexp <- surroundWs (mandatory (astParser @ExpressionWithLoc))+ pure $ ExpressionWithLoc (EOperator operator lexp rexp) (elLocation lexp)+ Nothing -> pure lexp++precedenceSort :: ExpressionWithLoc -> ExpressionWithLoc+precedenceSort (ExpressionWithLoc (EOperator op exL (ExpressionWithLoc (EOperator op1 exRL exRR) l2)) l1) =+ if op > op1+ then ExpressionWithLoc (EOperator op1 (ExpressionWithLoc (EOperator op (precedenceSort exL) (precedenceSort exRL)) l2) (precedenceSort exRR)) l1+ else ExpressionWithLoc (EOperator op (precedenceSort exL) (ExpressionWithLoc (EOperator op1 (precedenceSort exRL) (precedenceSort exRR)) l2)) l1+precedenceSort ex = ex
+ src/Compiler/AST/FunctionDef.hs view
@@ -0,0 +1,39 @@+module Compiler.AST.FunctionDef where++import Common+import Control.Applicative+import Data.List as L+import Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text as T++import Compiler.AST.Common+import Compiler.AST.FunctionStatement+import Compiler.AST.Parser.Common+import Compiler.Lexer+import Parser.Lib+import Test.Common++data FunctionDef+ = FunctionDef Identifier [Identifier] (NonEmpty FunctionStatementWithLoc)+ deriving (Show, Eq)++instance HasAstParser FunctionDef where+ astParser = nameParser "Function Definition" $ do+ surroundWs_ (parseKeyword KwProc)+ fnName <- surroundWs parseIdentifier+ args <- parseItemListInParen parseIdentifier+ stms <- mandatory (some (surroundWs (astParser @FunctionStatementWithLoc)))+ mandatory $ surroundWs_ $ parseKeyword KwEndProc+ pure $ FunctionDef fnName (fromMaybe [] (NE.toList <$> args)) (NE.fromList stms)++instance ToSource FunctionDef where+ toSourcePretty i (FunctionDef name args stms) =+ T.concat $+ [nlt, indent i, toSource KwProc, wst, toSource name, toSource DlParenOpen] <>+ (L.intersperse (toSource DlComma <> " ") (toSource <$> args)) <>+ [toSource DlParenClose] <> [nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <> [nlt, indent i, toSource KwEndProc]++instance HasGen FunctionDef where+ getGen = FunctionDef <$> getGen <*> getGen <*> (nonEmptyGen getGen)
+ src/Compiler/AST/FunctionStatement.hs view
@@ -0,0 +1,243 @@+module Compiler.AST.FunctionStatement where++import Control.Applicative+import Data.List as L+import Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text as T++import Common+import Compiler.AST.Common+import Compiler.AST.Expression+import Compiler.AST.Parser.Common+import Compiler.Lexer+import Compiler.Lexer.Comments+import Parser.Lib+import Parser.Parser+import Test.Common++data FunctionStatementWithLoc+ = FunctionStatementWithLoc FunctionStatement Location+ deriving Show++instance Eq FunctionStatementWithLoc where+ (FunctionStatementWithLoc fs1 _) == (FunctionStatementWithLoc fs2 _) = fs1 == fs2++instance ToSource FunctionStatementWithLoc where+ toSourcePretty i (FunctionStatementWithLoc fs _) = toSourcePretty i fs++instance HasAstParser FunctionStatementWithLoc where+ astParser = nameParser "FunctionStatement" $ do+ loc <- getParserLocation+ fsr <- astParser+ pure $ FunctionStatementWithLoc fsr loc++instance HasGen FunctionStatementWithLoc where+ getGen = FunctionStatementWithLoc <$> getGen <*> (pure emptyLocation)++data FunctionStatement+ = Let Subscript ExpressionWithLoc+ | Call Identifier [ExpressionWithLoc]+ | If ExpressionWithLoc (NonEmpty FunctionStatementWithLoc) (NonEmpty FunctionStatementWithLoc)+ | MultiIf ExpressionWithLoc (NonEmpty FunctionStatementWithLoc) (NonEmpty (ExpressionWithLoc, NonEmpty FunctionStatementWithLoc)) (Maybe (NonEmpty FunctionStatementWithLoc))+ | IfThen ExpressionWithLoc (NonEmpty FunctionStatementWithLoc)+ | For Identifier ExpressionWithLoc ExpressionWithLoc (NonEmpty FunctionStatementWithLoc)+ | ForEach Identifier ExpressionWithLoc (NonEmpty FunctionStatementWithLoc)+ | While ExpressionWithLoc (NonEmpty FunctionStatementWithLoc)+ | Loop (NonEmpty FunctionStatementWithLoc)+ | Return ExpressionWithLoc+ | Break+ | FnComment Comment+ deriving (Show, Eq)++instance ToSource FunctionStatement where+ toSourcePretty i Break = T.concat [indent i, toSource KwBreak]+ toSourcePretty i (FnComment c) = stripEnd (toSourcePretty i c)+ toSourcePretty i (Let idf expr) =+ T.concat [indent i, toSource KwLet, wst, toSource idf, wst, toSource KwAssignment, wst, toSource expr]+ toSourcePretty i (Call idf args) =+ T.concat $ [indent i, toSource idf, toSource DlParenOpen] <> argsSrc <> [toSource DlParenClose]+ where+ argsSrc = (L.intersperse (toSource DlComma <> " ") (toSource <$> args))+ toSourcePretty i (Return expr) = T.concat $ [indent i, toSource KwReturn, wst, toSource expr]+ toSourcePretty i (ForEach idf expr1 stms) =+ T.concat $+ [indent i, toSource KwForEach, wst, toSource expr1, wst, toSource KwAs, wst, toSource idf, wst, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <>+ [nlt, indent i, toSource KwEndForEach]+ toSourcePretty i (For idf expr1 expr2 stms) =+ T.concat $+ [indent i, toSource KwFor, wst, toSource idf, wst, toSource KwAssignment, wst, toSource expr1, wst, toSource KwTo, wst, toSource expr2, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <>+ [nlt, indent i, toSource KwEndFor]+ toSourcePretty i (IfThen expr stms) =+ T.concat $+ [indent i, toSource KwIf, wst, toSource expr, wst, toSource KwThen, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <>+ [nlt, indent i, toSourcePretty i KwEndIf]+ toSourcePretty i (MultiIf expr stms1 rst mstms2) =+ T.concat $+ [indent i, toSource KwIf, wst, toSource expr, wst, toSource KwThen, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms1)] <>+ (toSourceElseIf <$> (NE.toList rst)) <>+ [nlt, toSourceElse] <>+ [indent i, toSource KwEndIf]+ where+ toSourceElse :: Text+ toSourceElse = case mstms2 of+ Just stms -> T.concat $+ [indent i, toSource KwElse, nlt] <> [toSourcePretty (i+1) (NE.toList stms)] <> [nlt]+ Nothing -> ""+ toSourceElseIf :: (ExpressionWithLoc, NonEmpty FunctionStatementWithLoc) -> Text+ toSourceElseIf (expr1, stms3) =+ T.concat $+ [nlt, indent i, toSource KwElseIf, wst, toSource expr1, wst, toSource KwThen, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms3)]+ toSourcePretty i (If expr stms1 stms2) =+ T.concat $+ [indent i, toSource KwIf, wst, toSource expr, wst, toSource KwThen, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms1)] <>+ [nlt, indent i, toSource KwElse, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms2)] <>+ [nlt, indent i, toSource KwEndIf]+ toSourcePretty i (While expr1 stms) =+ T.concat $+ [indent i, toSource KwWhile, wst, toSource expr1, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <>+ [nlt, indent i, toSource KwEndWhile]+ toSourcePretty i (Loop stms) =+ T.concat $+ [indent i, toSource KwLoop, nlt] <>+ [toSourcePretty (i+1) (NE.toList stms)] <>+ [nlt, indent i, toSource KwEndLoop]++instance HasGen FunctionStatement where+ getGen = recursive choice+ [ Let <$> getGen <*> getGen+ , Call <$> getGen <*> getGen+ , Return <$> getGen+ , FnComment <$> getGen+ , pure Break+ ]+ [ If <$> getGen <*> (nonEmptyGen getGen) <*> (nonEmptyGen getGen)+ , IfThen <$> getGen <*> (nonEmptyGen getGen)+ , MultiIf <$> getGen <*> (nonEmptyGen getGen) <*> (nonEmptyGen ((,) <$> getGen <*> (nonEmptyGen getGen))) <*> (Test.Common.maybe (nonEmptyGen getGen))+ , For <$> getGen <*> getGen <*> getGen <*> (nonEmptyGen getGen)+ , Loop <$> (nonEmptyGen getGen)+ , While <$> getGen <*> (nonEmptyGen getGen)+ ]++instance HasAstParser FunctionStatement where+ astParser = nameParser "Function statement (raw)" $ do+ (whitespaceNL <|> whitespace)+ functionStatementParser++functionStatementParser :: AstParser FunctionStatement+functionStatementParser+ = ifParser+ <|> letParser+ <|> forEachParser+ <|> forParser+ <|> whileParser+ <|> loopParser+ <|> returnParser+ <|> breakParser+ <|> callStatementParser+ <|> (FnComment <$> (surroundWs parseComment))++letParser :: AstParser FunctionStatement+letParser = nameParser "Let statement" $ do+ surroundWs_ (parseKeyword KwLet)+ idf <- surroundWs (mandatory parseSubscript)+ surroundWs_ (mandatory (parseToken "assignment" isAssignment))+ expr <- surroundWs (mandatory (astParser @ExpressionWithLoc))+ pure $ Let idf expr+ where+ isAssignment (TkKeyword KwAssignment) = Just ()+ isAssignment _ = Nothing++callStatementParser :: AstParser FunctionStatement+callStatementParser = nameParser "Function call" $ do+ idf <- surroundWs parseIdentifier+ args <- parseItemListInParen (astParser @ExpressionWithLoc)+ pure $ Call idf $ fromMaybe [] (NE.toList <$> args)++loopParser :: AstParser FunctionStatement+loopParser = nameParser "Loop Statement" $ do+ surroundWs_ (parseKeyword KwLoop)+ stms <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory (parseKeyword KwEndLoop))+ pure $ Loop (NE.fromList stms)++whileParser :: AstParser FunctionStatement+whileParser = nameParser "While Statement" $ do+ surroundWs_ (parseKeyword KwWhile)+ guardBool <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ stms <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory (parseKeyword KwEndWhile))+ pure $ While guardBool (NE.fromList stms)++forParser :: AstParser FunctionStatement+forParser = nameParser "For Statement" $ do+ surroundWs_ (parseKeyword KwFor)+ idf <- surroundWs (mandatory parseIdentifier)+ surroundWs_ (mandatory $ parseKeyword KwAssignment)+ startExp <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ surroundWs_ (mandatory (parseKeyword KwTo))+ endExp <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ stms <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory (parseKeyword KwEndFor))+ pure $ For idf startExp endExp (NE.fromList stms)++forEachParser :: AstParser FunctionStatement+forEachParser = nameParser "ForEach Statement" $ do+ surroundWs_ (parseKeyword KwForEach)+ expr <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwAs)+ idf <- surroundWs (mandatory parseIdentifier)+ stms <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory (parseKeyword KwEndForEach))+ pure $ ForEach idf expr (NE.fromList stms)++ifParser :: AstParser FunctionStatement+ifParser = nameParser "If Statement" $ do+ surroundWs_ (parseKeyword KwIf)+ expr <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwThen)+ stms1 <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs (mandatory (parseKeyword KwElseIf <|> parseKeyword KwElse <|> parseKeyword KwEndIf)) >>= \case+ KwElseIf -> do+ expr' <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwThen)+ stms2 <- mandatory (some $ astParser @FunctionStatementWithLoc)+ remaining <- many $ do+ surroundWs_ $ parseKeyword KwElseIf+ expr1 <- surroundWs (mandatory $ astParser @ExpressionWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwThen)+ stms3 <- mandatory (some $ astParser @FunctionStatementWithLoc)+ pure (expr1, NE.fromList stms3)+ surroundWs (mandatory (parseKeyword KwElse <|> parseKeyword KwEndIf)) >>= \case+ KwElse -> do+ elseStms <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwEndIf)+ pure $ MultiIf expr (NE.fromList stms1) ((expr', NE.fromList stms2) :| remaining) (Just $ NE.fromList elseStms)+ KwEndIf ->+ pure $ MultiIf expr (NE.fromList stms1) ((expr', NE.fromList stms2) :| remaining) Nothing+ _ -> fail "Impossible"+ KwElse -> do+ stms2 <- mandatory (some $ astParser @FunctionStatementWithLoc)+ surroundWs_ (mandatory $ parseKeyword KwEndIf)+ pure $ If expr (NE.fromList stms1) (NE.fromList stms2)+ KwEndIf ->+ pure $ IfThen expr (NE.fromList stms1)+ _ -> fail "Impossible"++returnParser :: AstParser FunctionStatement+returnParser = nameParser "return statement" $ do+ surroundWs_ (parseKeyword KwReturn)+ Return <$> (surroundWs $ astParser @ExpressionWithLoc)++breakParser :: AstParser FunctionStatement+breakParser = nameParser "break statement" $ do+ surroundWs_ (parseKeyword KwBreak)+ pure Break
+ src/Compiler/AST/Parser/Common.hs view
@@ -0,0 +1,44 @@+module Compiler.AST.Parser.Common where++import Compiler.Lexer+import Parser+import Common++type AstParser a = ParserM IO AstParserState a++data AstParserState = AstParserState+ { astInput :: [Token]+ , astIndent :: Int+ } deriving Show++instance HaveLocation AstParserState where+ getLocation (astInput -> (t:_)) = tkLocation t+ getLocation _ = error "No location for empty input"++instance HasEmpty AstParserState where+ isEmpty s = astInput s == []++mkAstParserState :: [Token] -> AstParserState+mkAstParserState ts = AstParserState ts 0++liftModifier+ :: Monad m+ => ([Token] -> m (Either ParseError a, [Token]))+ -> (AstParserState -> m (Either ParseError a, AstParserState))+liftModifier fn = \s -> do+ (fn $ astInput s) >>= \case+ (r, rst) -> pure (r, s { astInput = rst })++instance {-# OVERLAPS #-} HasLogIndent AstParserState where+ incIndent a = a { astIndent = astIndent a + 1 }+ decIndent a = a { astIndent = astIndent a - 1 }+ logInfo _ _ = pure ()+ -- logInfo name ps = liftIO $ do+ -- T.putStr $ T.replicate (astIndent ps) " "+ -- T.putStrLn $ T.pack $ show (name, Prelude.take 2 $ astInput ps)++instance ToSource AstParserState where+ toSource s = toSource $ astInput s++class HasAstParser a where+ astParser :: AstParser a
+ src/Compiler/AST/Program.hs view
@@ -0,0 +1,48 @@+module Compiler.AST.Program+ ( module Compiler.AST.Expression+ , module Compiler.AST.Program+ , module Compiler.AST.FunctionDef+ )+where++import Control.Applicative+import Data.Text as T++import Common+import Compiler.AST.Common+import Compiler.AST.Expression+import Compiler.AST.FunctionDef+import Compiler.AST.FunctionStatement+import Compiler.AST.Parser.Common+import Compiler.Lexer.Comments+import Test.Common++type StringType = Text++data ProgramStatement+ = FunctionDefStatement FunctionDef+ | NakedStatement FunctionStatementWithLoc+ | TopLevelComment Comment+ deriving (Show, Eq)++type Program = [ProgramStatement]++instance ToSource ProgramStatement where+ toSource (FunctionDefStatement def) = toSource def+ toSource (NakedStatement fns) = toSource fns+ toSource (TopLevelComment cmm) = toSource cmm++instance HasAstParser ProgramStatement where+ astParser+ = (FunctionDefStatement <$> astParser)+ <|> (NakedStatement <$> (astParser @FunctionStatementWithLoc))+ <|> (TopLevelComment <$> parseComment)++instance HasGen ProgramStatement where+ getGen = choice+ [ FunctionDefStatement <$> getGen+ , NakedStatement <$> getGen+ ]++instance HasAstParser Program where+ astParser = many (astParser @ProgramStatement)
+ src/Compiler/Lexer.hs view
@@ -0,0 +1,17 @@+module Compiler.Lexer+ ( module Compiler.Lexer.Delimeters+ , module Compiler.Lexer.Identifiers+ , module Compiler.Lexer.Keywords+ , module Compiler.Lexer.Literals+ , module Compiler.Lexer.Operators+ , module Compiler.Lexer.Tokens+ , module Compiler.Lexer.Whitespaces+ ) where++import Compiler.Lexer.Delimeters+import Compiler.Lexer.Identifiers+import Compiler.Lexer.Keywords+import Compiler.Lexer.Literals+import Compiler.Lexer.Operators+import Compiler.Lexer.Tokens+import Compiler.Lexer.Whitespaces
+ src/Compiler/Lexer/Comments.hs view
@@ -0,0 +1,28 @@+module Compiler.Lexer.Comments where++import Common+import Control.Applicative+import Control.Monad+import Data.Text as T+import Parser+import Test.Common++newtype Comment = Comment Text+ deriving (Show, Eq)++commentPrefix :: Text+commentPrefix = "-- "++instance HasParser Comment where+ parser = do+ void $ pText commentPrefix+ c <- many (nameParser "comment_char" $ pAny (\c -> c /= '\n'))+ (void $ pChar '\n') <|> eof+ incLine 1+ pure $ Comment (pack c)++instance ToSource Comment where+ toSourcePretty i (Comment c) = indent i <> commentPrefix <> c <> "\n"++instance HasGen Comment where+ getGen = (Comment . T.append "comment_prefix") <$> (text (linear 0 50) (enum 'a' 'z'))
+ src/Compiler/Lexer/Delimeters.hs view
@@ -0,0 +1,48 @@+module Compiler.Lexer.Delimeters where++import Common+import Control.Applicative+import Parser+import Test.Common++data Delimeter+ = DlColon+ | DlComma+ | DlPeriod+ | DlParenOpen+ | DlParenClose+ | DlSquareParenOpen+ | DlSquareParenClose+ | DlBraceParenOpen+ | DlBraceParenClose+ deriving (Show, Lift, Eq, Enum)++instance HasParser Delimeter where+ parser+ = parseFor DlColon+ <|> parseFor DlPeriod+ <|> parseFor DlParenOpen+ <|> parseFor DlParenClose+ <|> parseFor DlSquareParenOpen+ <|> parseFor DlSquareParenClose+ <|> parseFor DlBraceParenOpen+ <|> parseFor DlBraceParenClose+ <|> parseFor DlComma+ where+ parseFor :: Delimeter -> Parser Delimeter+ parseFor kw = parseAndReturn (toSource kw) kw++instance ToSource Delimeter where+ toSource = \case+ DlColon -> ":"+ DlPeriod -> "."+ DlParenOpen -> "("+ DlParenClose -> ")"+ DlSquareParenOpen -> "["+ DlSquareParenClose -> "]"+ DlBraceParenOpen -> "{"+ DlBraceParenClose -> "}"+ DlComma -> ","++instance HasGen Delimeter where+ getGen = enum DlColon DlBraceParenClose
+ src/Compiler/Lexer/Identifiers.hs view
@@ -0,0 +1,33 @@+module Compiler.Lexer.Identifiers where++import Common+import Control.Applicative+import Data.Char+import Data.String+import Data.Text as T+import Parser+import Test.Common++newtype Identifier = Identifier { unIdentifer :: Text }+ deriving (Show, Eq, Ord)++instance IsString Identifier where+ fromString = Identifier . T.pack++instance HasParser Identifier where+ parser = (\x -> Identifier $ pack x) <$> (do+ s <- pAny isAsciiLower+ rst <- many (pAny (\x -> isAlphaNum x || x == '_'))+ pure (s : rst)+ )++instance ToSource Identifier where+ toSource = unIdentifer++instance HasGen Identifier where+ getGen = Identifier <$> choice+ [ gen+ , do x <- gen; s <- int (linear 0 999); pure (x <> (pack $ show s))+ ]+ where+ gen = ((pack . (\x -> "identi" <> x)) <$> (list (linear 1 10) (choice [lower, upper])))
+ src/Compiler/Lexer/Keywords.hs view
@@ -0,0 +1,106 @@+module Compiler.Lexer.Keywords where++import Common+import Compiler.Lexer.Whitespaces+import Control.Applicative+import Control.Monad+import Parser+import Test.Common++data Keyword+ = KwFor+ | KwEndFor+ | KwForEach+ | KwAs+ | KwEndForEach+ | KwBreak+ | KwWhile+ | KwEndWhile+ | KwLet+ | KwIf+ | KwEndFn+ | KwThen+ | KwElseIf+ | KwElse+ | KwEndIf+ | KwProc+ | KwLoop+ | KwEndLoop+ | KwEndProc+ | KwTo+ | KwReturn+ | KwAssignment+ | KwFn -- We don't want to generate this in automatic tests because of the lookahead for (+ deriving (Show, Lift,Eq, Enum, Bounded)++instance HasParser Keyword where+ parser+ = parseFor KwForEach+ <|> parseFor KwEndForEach+ <|> parseFor KwFor+ <|> parseFor KwAs+ <|> parseFor KwEndFor+ <|> parseFor KwWhile+ <|> parseFor KwBreak+ <|> parseFor KwEndWhile+ <|> parseFor KwLet+ <|> parseFor KwIf+ <|> parseFor KwFn+ <|> parseFor KwEndFn+ <|> parseFor KwThen+ <|> parseFor KwElseIf+ <|> parseFor KwElse+ <|> parseFor KwEndIf+ <|> parseFor KwProc+ <|> parseFor KwLoop+ <|> parseFor KwEndLoop+ <|> parseFor KwEndProc+ <|> parseFor KwTo+ <|> parseFor KwReturn+ <|> parseFor KwAssignment+ where+ parseFor :: Keyword -> Parser Keyword+ parseFor kw = do+ pkw <- parseAndReturn (toSource kw) kw+ case pkw of+ KwAssignment -> pure pkw+ KwFn -> do+ lookAhead ((void $ do+ void $ many (parser @Whitespace)+ pText "(")) >>= \case+ Just _ -> pure pkw+ Nothing -> cantHandle+ KwEndFn -> pure pkw+ _ -> do+ lookAhead ((void $ parser @Whitespace) <|> eof) >>= \case+ Just _ -> pure pkw+ Nothing -> cantHandle++instance ToSource Keyword where+ toSource = \case+ KwFor -> "for"+ KwEndFor -> "endfor"+ KwForEach -> "foreach"+ KwAs -> "as"+ KwEndForEach -> "endforeach"+ KwBreak -> "break"+ KwWhile -> "while"+ KwEndWhile -> "endwhile"+ KwLet -> "let"+ KwIf -> "if"+ KwFn -> "fn"+ KwEndFn -> "endfn"+ KwThen -> "then"+ KwElseIf -> "elseif"+ KwElse -> "else"+ KwEndIf -> "endif"+ KwProc -> "proc"+ KwLoop -> "loop"+ KwEndProc -> "endproc"+ KwEndLoop -> "endloop"+ KwTo -> "to"+ KwReturn -> "return"+ KwAssignment -> "="++instance HasGen Keyword where+ getGen = enum KwFor KwAssignment
+ src/Compiler/Lexer/Literals.hs view
@@ -0,0 +1,87 @@+module Compiler.Lexer.Literals where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as BS+import Data.Char+import Data.Text as T+import Data.Decimal+import Text.Read hiding (choice)+import Text.Hex (decodeHex, encodeHex)++import Parser.Lib+import Parser.Parser+import Test.Common+import Common++data Literal+ = LitString Text+ | LitNumber IntType+ | LitFloat Decimal -- This needs to be a decimal so that string round tripping can work.+ | LitBool Bool+ | LitBytes BS.ByteString+ deriving (Eq, Show)++instance HasGen Literal where+ getGen = choice+ [ LitString <$> (text (linear 0 50) (enum 'a' 'z'))+ , LitFloat <$> realFrac_ (linearFrac 0 999.00)+ , (LitNumber . fromIntegral) <$> int (linear 0 999)+ , LitBool <$> bool+ ]++instance ToSource Literal where+ toSource = \case+ LitBytes t -> "0x" <> (encodeHex t) <> ""+ LitString t -> "\"" <> t <> "\""+ LitNumber n -> (T.pack $ show n)+ LitFloat n -> let o = T.pack $ show n in+ if T.isInfixOf "." o then o else o <> ".0"+ LitBool n -> (T.toLower $ T.pack $ show n)++instance HasParser Literal where+ parser+ = strLiteralParser+ <|> floatLiteralParser+ <|> hexLiteralParser+ <|> intLiteralParser+ <|> boolLiteralParser++strLiteralParser :: Parser Literal+strLiteralParser = do+ void $ pChar '"'+ c <- many (pAny (\c -> c /= '"'))+ void $ pChar '"'+ pure $ LitString (pack c)++hexLiteralParser :: Parser Literal+hexLiteralParser = do+ void $ pText "0x"+ c <- many (pAny isHexDigit)+ case decodeHex $ T.pack c of+ Just b -> pure $ LitBytes b+ Nothing -> cantHandle++intLiteralParser :: Parser Literal+intLiteralParser = do+ c <- many (pAny isDigit)+ case c of+ ['0'] -> pure $ LitNumber 0+ ('0':_) -> cantHandle+ _ -> case readEither c of+ Right n -> pure $ LitNumber n+ Left _ -> cantHandle++floatLiteralParser :: Parser Literal+floatLiteralParser = do+ c <- many (pAny (\c -> isDigit c))+ _ <- pChar '.'+ m <- many (pAny isDigit)+ case readEither (c <> "." <> m) of+ Right a -> pure $ LitFloat a+ Left _ -> cantHandle++boolLiteralParser :: Parser Literal+boolLiteralParser =+ (do void $ pText "true"; pure $ LitBool True) <|>+ (do void $ pText "false"; pure $ LitBool False)
+ src/Compiler/Lexer/Operators.hs view
@@ -0,0 +1,57 @@+module Compiler.Lexer.Operators where++import Common+import Control.Applicative+import Parser+import Test.Common++data Operator+ = OpAnd+ | OpOr+ | OpLT -- Order here sets the operator precedence (bottom ones have higher)+ | OpGT+ | OpLTE+ | OpGTE+ | OpEquality+ | OpNotEquality+ | OpPlus+ | OpMinus+ | OpStar+ | OpDivide+ deriving (Show, Ord, Eq, Enum, Bounded)++instance HasParser Operator where+ parser+ = parseFor OpPlus+ <|> parseFor OpStar+ <|> parseFor OpMinus+ <|> parseFor OpDivide+ <|> parseFor OpLTE+ <|> parseFor OpGTE+ <|> parseFor OpLT+ <|> parseFor OpGT+ <|> parseFor OpEquality+ <|> parseFor OpNotEquality+ <|> parseFor OpAnd+ <|> parseFor OpOr+ where+ parseFor :: Operator -> Parser Operator+ parseFor kw = parseAndReturn (toSource kw) kw++instance ToSource Operator where+ toSource = \case+ OpPlus -> "+"+ OpStar -> "*"+ OpMinus -> "-"+ OpDivide -> "/"+ OpLT -> "<"+ OpGT -> ">"+ OpLTE -> "<="+ OpGTE -> ">="+ OpEquality -> "=="+ OpNotEquality -> "!=="+ OpAnd -> "and"+ OpOr -> "or"++instance HasGen Operator where+ getGen = enum OpPlus OpOr
+ src/Compiler/Lexer/Tokens.hs view
@@ -0,0 +1,118 @@+module Compiler.Lexer.Tokens where++import Control.Applicative+import Data.List (intersperse)+import qualified Data.Text as T+import System.Console.ANSI (Color(..))++import Common+import Compiler.Lexer.Comments+import Compiler.Lexer.Delimeters+import Compiler.Lexer.Identifiers+import Compiler.Lexer.Keywords+import Compiler.Lexer.Literals+import Compiler.Lexer.Operators+import Compiler.Lexer.Whitespaces+import Parser+import Test.Common++data Token = Token+ { tkRaw :: TokenRaw+ , tkLocation :: Location+ , tkOffsetEnd :: Int+ } deriving (Show)++highlightTokens :: (StyledText, Maybe Token) -> StyledText+highlightTokens (src, Nothing) = src+highlightTokens (src, Just (tkRaw -> tk)) =+ case tk of+ TkKeyword _ -> StyledText (Fg Red) [src] --setSGRCode [SetColor Foreground Vivid Red]+ TkDelimeter _ -> StyledText (Fg Blue) [src] -- setSGRCode [SetColor Foreground Vivid Blue]+ TkLiteral _ -> StyledText (Fg Magenta) [src] -- setSGRCode [SetColor Foreground Vivid Magenta]+ TkOperator _ -> StyledText (Fg Cyan) [src] -- setSGRCode [SetColor Foreground Vivid Cyan]+ TkIdentifier _ -> StyledText (Fg Yellow) [src] -- setSGRCode [SetColor Foreground Vivid Yellow]+ TkComment _ -> StyledText (Fg Black) [src]+ TkWhitespace _ -> src++instance Highlightable Token where+ getTokenLoc = tkLocation+ highlight = highlightTokens+ pairWithTokens tokenStack startOffset source =+ genericPairWithTokens tkOffsetEnd tkLocation startOffset source tokenStack++instance Eq Token where+ (Token tr1 _ _ ) == (Token tr2 _ _) = tr1 == tr2++data TokenRaw+ = TkKeyword Keyword+ | TkDelimeter Delimeter+ | TkLiteral Literal+ | TkOperator Operator+ | TkWhitespace Whitespace+ | TkIdentifier Identifier+ | TkComment Comment+ deriving (Show, Eq)++instance HasParser TokenRaw where+ parser+ = (TkComment <$> parser)+ <|> (TkOperator <$> parser)+ <|> (TkKeyword <$> parser)+ <|> (TkDelimeter <$> parser)+ <|> (TkLiteral <$> parser)+ <|> (TkWhitespace <$> parser)+ <|> (TkIdentifier <$> parser)++-- This is expected to return the exact source+-- that was parsed into the token, and this property+-- is used in syntax-highlighting.+instance ToSource TokenRaw where+ toSource = \case+ TkKeyword kw -> toSource kw+ TkDelimeter d -> toSource d+ TkLiteral l -> toSource l+ TkOperator o -> toSource o+ TkWhitespace w -> toSource w+ TkComment w -> toSource w+ TkIdentifier i -> toSource i++instance {-# OVERLAPPING #-} ToSource [TokenRaw] where+ toSource a = T.concat $ toSource <$> a++instance {-# OVERLAPPING #-} ToSource [Token] where+ toSource a = T.concat $ toSource <$> a++instance HasGen TokenRaw where+ getGen = choice+ [ (TkKeyword <$> getGen)+ , (TkDelimeter <$> getGen)+ , (TkLiteral <$> getGen)+ , (TkOperator <$> getGen)+ , (TkWhitespace <$> getGen)+ , (TkComment <$> getGen)+ ]++instance {-# OVERLAPS #-} HasGen [TokenRaw] where+ getGen =+ (normalizeWhiteSpace . intersperse (TkWhitespace $ Space 1)) <$> (list (linear 0 500) getGen)++normalizeWhiteSpace :: [TokenRaw] -> [TokenRaw]+normalizeWhiteSpace (TkWhitespace (Space w1) : TkWhitespace (Space w2) : rst) =+ normalizeWhiteSpace (TkWhitespace (Space (w1 + w2)) : rst)+normalizeWhiteSpace (TkWhitespace (NewLine w1) : TkWhitespace (NewLine w2) : rst) =+ normalizeWhiteSpace (TkWhitespace (NewLine (w1 + w2)) : rst)+normalizeWhiteSpace (h:rst) = h : normalizeWhiteSpace rst+normalizeWhiteSpace [] = []++instance HasInnerParseable Token where+ type InnerToken Token = TokenRaw+ assemble = Token++instance HasGen Token where+ getGen = Token <$> getGen <*> (pure emptyLocation) <*> (pure 0)++instance ToSource Token where+ toSource (Token tr _ _) = toSource tr++instance {-# OVERLAPS #-} HasGen [Token] where+ getGen = (fmap (\tr -> Token tr emptyLocation 0)) <$> getGen
+ src/Compiler/Lexer/Whitespaces.hs view
@@ -0,0 +1,38 @@+module Compiler.Lexer.Whitespaces where++import Common+import Control.Applicative+import Data.Text as T hiding (length)+import Parser+import Test.Common++data Whitespace+ = Space Int+ | Tab Int+ | NewLine Int+ deriving (Show, Eq)++instance HasParser Whitespace where+ parser+ = spaceParser <|> tabParser <|> newlineParser+ where+ spaceParser = ((\c -> Space (length c)) <$> (some (pChar ' ')))+ tabParser = ((\c -> Tab (length c)) <$> (some (pChar '\t')))+ newlineParser = do+ nls <- some (pChar '\n')+ let lc = length nls+ incLine lc+ pure $ NewLine lc++instance ToSource Whitespace where+ toSource = \case+ Space c -> T.replicate c " "+ Tab c -> T.replicate c "\t"+ NewLine c -> T.replicate c "\n"++instance HasGen Whitespace where+ getGen = choice+ [ Space <$> (int (linear 1 10))+ , Tab <$> (int (linear 1 10))+ , NewLine <$> (int (linear 1 10))+ ]
+ src/Compiler/Parser.hs view
@@ -0,0 +1,36 @@+module Compiler.Parser where++import Control.Monad.IO.Class (liftIO)++import Compiler.AST.Parser.Common+import Compiler.AST.Program+import Compiler.Lexer+import Data.Text as T+import Parser++tokenize :: Text -> IO [Token]+tokenize src = liftIO $ runParserEither (parser @[Token]) (toTextWithOffset src) >>= \case+ Right ts -> pure ts+ Left (ParseErrorWithParsed (Just partial) _ (FatalError IncompleteParse)) -> pure partial+ Left _ -> pure []++parse :: [Token] -> IO Program+parse tks = parseEither tks >>= \case+ Right p -> pure p+ Left err -> error $ show err++parseEither :: (Show a, HasAstParser a) => [Token] -> IO (Either (ParseErrorWithParsed a) a)+parseEither tks = runParserEither astParser (mkAstParserState tks)++parseRaw :: Text -> AstParser a -> IO (Either (ParseErrorWithParsed a) a)+parseRaw src astP = do+ tokens <- tokenize src+ runParserEither astP (mkAstParserState tokens)++compile :: (Show a, HasAstParser a) => Text -> IO a+compile src = compileEither src >>= \case+ Right p -> pure p+ Left err -> error $ show err++compileEither :: forall a. (Show a, HasAstParser a) => Text -> IO (Either (ParseErrorWithParsed a) a)+compileEither src = tokenize src >>= parseEither
+ src/Highlighter/Highlighter.hs view
@@ -0,0 +1,17 @@+module Highlighter.Highlighter where++import Data.Text+import Common+import System.Console.ANSI (Color(..), Underlining(..), SGR(..), setSGRCode)++underlineText :: Text -> Text+underlineText t = let+ startCode = (setSGRCode [SetUnderlining SingleUnderline])+ endCode = setSGRCode []+ in (pack startCode) <> t <> (pack endCode)++colorText :: Color -> Color -> Text -> StyledText+colorText fg bg t = StyledText (FgBg fg bg) [Plain t]++colorTextFg :: Color -> Text -> StyledText+colorTextFg fg t = StyledText (Fg fg) [Plain t]
+ src/IDE/Common.hs view
@@ -0,0 +1,30 @@+module IDE.Common where++import UI.Widgets.Common+import Common+import Interpreter.Common++data EditAction+ = Cut+ | Copy+ | Paste+ | SelectAll+ deriving Show++data IDEEvent+ = IDETerminalEvent TerminalEvent+ | IDEReqEditorContent+ | IDEParseErrorUpdate (Maybe (Location, Text))+ | IDEACUpdateIdentifiers [Text]+ | IDEDraw+ | IDEToggleHelp+ | IDESave+ | IDEExit+ | IDEEdit EditAction+ | IDEBeautify+ | IDEClearLog+ | IDEStep+ | IDEDebugUpdate (Maybe DebugState)+ | IDERun+ deriving Show+
+ src/IDE/Help.hs view
@@ -0,0 +1,317 @@+module IDE.Help where++import Compiler.Lexer.Keywords (Keyword)+import Compiler.Lexer.Operators (Operator)+import Control.Concurrent+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Monad as CM+import qualified Data.ByteString as BS+import Data.IORef+import qualified Data.List as DL+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Vector as V++import Common+import Compiler.AST.Program+import Compiler.Parser+import IDE.Common+import IDE.Help.Contents+import IDE.Help.Parser+import UI.Widgets+import UI.Widgets.Layout+import UI.Widgets.NullWidget++newtype SearchPage = SearchPage Text+ deriving Show++type HelpPage = Either SearchPage FilePath++data HelpWidget = HelpWidget+ { hwSearchWidget :: WRef EditorWidget+ , hwContentWidget :: WRef EditorWidget+ , hwMainLayout :: WRef LayoutWidget+ , hwVisible :: Bool+ , hwCursorRef :: MVar Int+ , hwTokenProcessingThread :: Maybe ThreadId+ , hwIdeEventsChan :: TChan IDEEvent+ , hwTokensRef :: IORef (V.Vector DisplayToken)+ , hwContent :: Map.Map FilePath (Text, V.Vector DisplayToken)+ , hwContentIndex :: Map.Map Text (FilePath, Int)+ , hwCurrentPage :: Maybe HelpPage+ , hwHistory :: [(HelpPage, Int)]+ , hwSearchResult :: MVar (SearchPage, V.Vector HToken)+ , hwSearchChan :: TChan SearchPage+ }++instance Drawable HelpWidget where+ draw r = do+ w <- readWRef r+ case hwVisible w of+ True -> do+ (liftIO $ tryTakeMVar (hwSearchResult w)) >>= \case+ Just (sp, htokens) -> do+ let (contentText, dTokens) = convertToDisplay htokens+ loadTokens r (contentText, dTokens)+ modifyWRef r (\wd -> wd { hwCurrentPage = Just (Left sp) })+ Nothing -> pass+ draw $ hwMainLayout w+ _ -> pass+ setVisibility r v = do+ modifyWRef r (\hw -> hw { hwVisible = v })+ getVisibility r =+ hwVisible <$> readWRef r++instance KeyInput HelpWidget where+ getCursorInfo r = do+ w <- readWRef r+ getCursorInfo $ hwSearchWidget w+ handleInput :: forall m. WidgetC m => WRef HelpWidget -> KeyEvent -> m ()+ handleInput r ke = do+ w <- readWRef r+ let+ pushCurrentPageToHistory :: m ()+ pushCurrentPageToHistory = do+ case hwCurrentPage w of+ Just p -> do+ cw <- readWRef (hwContentWidget w)+ let currentOffset = ewCursor cw+ modifyWRef r (\hw ->+ hw { hwHistory = (p, currentOffset) : hwHistory hw }+ )+ Nothing -> pure ()++ loadPage' :: HelpPage -> Int -> m ()+ loadPage' page idx = do+ loadPage r page+ modifyWRef (hwContentWidget w) (\x -> let+ newEw = putCursor Nothing idx x+ newSo = computeScrollOffset newEw (fst $ ewCursorInfo newEw)+ in newEw { ewScrollOffset = if newSo /= ewScrollOffset x then newSo + (div (diH $ ewDim newEw) 2) else newSo }+ )+ case ke of+ KeyCtrl _ _ _ Esc -> do+ case hwHistory w of+ [] -> pure ()+ ((p, o) :rst) -> do+ modifyWRef r (\hw -> hw { hwHistory = rst })+ loadPage' p o+ KeyCtrl _ _ _ ArrowUp -> handleInput (hwContentWidget w) ke+ KeyCtrl _ _ _ ArrowDown -> handleInput (hwContentWidget w) ke+ KeyCtrl _ _ _ ArrowRight -> handleInput (hwContentWidget w) ke+ KeyCtrl _ _ _ ArrowLeft -> handleInput (hwContentWidget w) ke+ KeyCtrl _ _ _ Return -> do+ tokens <- liftIO $ readIORef (hwTokensRef w)+ case V.find (\case+ DisplayToken (DTLink True _) _ _ -> True+ _ -> False) tokens of+ Just (DisplayToken (DTLink _ n) _ _) -> case Map.lookup n (hwContentIndex w) of+ Just (page, idx) -> do+ pushCurrentPageToHistory+ loadPage' (Right page) idx+ Nothing -> pure ()+ _ -> pure ()+ _ -> do+ handleInput (hwSearchWidget w) ke+ swr <- readWRef (hwSearchWidget w)+ loadPage' (Left (SearchPage $ ewContent swr)) 0++ ew <- readWRef (hwContentWidget w)+ void $ liftIO $ tryPutMVar (hwCursorRef w) (ewCursor ew)++instance Moveable HelpWidget where+ move r pos = do+ w <- hwMainLayout <$> readWRef r+ move w pos+ getPos r = do+ w <- hwMainLayout <$> readWRef r+ getPos w+ getDim r = do+ w <- hwMainLayout <$> readWRef r+ getDim w+ resize r fn = do+ w <- hwMainLayout <$> readWRef r+ resize w fn++instance Widget HelpWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (KeyInputCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability _ = Nothing++searchThread+ :: Map.Map Text (FilePath, Int)+ -> TChan SearchPage+ -> MVar (SearchPage, V.Vector HToken)+ -> IO ()+searchThread contentIndex spChan resultRef = do+ let indexKeys = Map.keys contentIndex+ forever $ do+ SearchPage (T.toLower -> skey) <- atomically $ readTChan spChan+ let results = DL.foldl' (foldFn skey) [] indexKeys+ putMVar resultRef (SearchPage skey, V.fromList (mkHToken <$> results))+ where+ mkHToken x = HToken x emptyLocation 0+ foldFn :: Text -> [HTokenRaw] -> Text -> [HTokenRaw]+ foldFn k rs hd = if k `T.isInfixOf` (T.toLower hd) then (Link hd : NewLine : rs) else rs++loadPage+ :: WidgetC m+ => WRef HelpWidget+ -> HelpPage+ -> m ()+loadPage ref page' = do+ HelpWidget { hwContent = map' } <- readWRef ref+ case page' of+ Right page -> case Map.lookup page map' of+ Nothing -> pure ()+ Just (contentText, dtTokens) -> do+ loadTokens ref (contentText, dtTokens)+ modifyWRef ref (\hw -> hw { hwCurrentPage = Just page' })+ Left (SearchPage "") -> loadPage ref (Right "toc.md")+ Left sk -> do+ w <- readWRef ref+ liftIO $ atomically $ writeTChan (hwSearchChan w) sk++loadTokens+ :: WidgetC m+ => WRef HelpWidget+ -> (Text, V.Vector DisplayToken)+ -> m ()+loadTokens helpWidgetRef (contentText, dtTokens) = do+ HelpWidget { hwIdeEventsChan = ideEventRef, hwContentWidget = ewRef, hwTokensRef = tokensRef} <- readWRef helpWidgetRef+ liftIO $ writeIORef tokensRef dtTokens+ modifyWRef ewRef (\ew -> ew { ewScrollOffset = 0, ewContent = contentText, ewShowVirtualCursor = True })+ liftIO $ atomically $ writeTChan ideEventRef IDEDraw++collectLinks+ :: Map.Map FilePath (Text, V.Vector DisplayToken)+ -> [Text]+collectLinks docs = Map.foldrWithKey mapFoldFn mempty docs+ where+ mapFoldFn+ :: FilePath+ -> (Text, V.Vector DisplayToken)+ -> [Text]+ -> [Text]+ mapFoldFn fp (_, tkns) idx = V.foldl' (foldFn fp) idx tkns++ foldFn+ :: FilePath+ -> [Text]+ -> DisplayToken+ -> [Text]+ foldFn _ idx (DisplayToken (DTLink _ t) _ _) = t : idx+ foldFn _ idx _ = idx++buildIndex+ :: Map.Map FilePath (Text, V.Vector DisplayToken)+ -> Map.Map Text (FilePath, Int)+buildIndex docs = Map.foldrWithKey mapFoldFn mempty docs+ where+ mapFoldFn+ :: FilePath+ -> (Text, V.Vector DisplayToken)+ -> Map.Map Text (FilePath, Int)+ -> Map.Map Text (FilePath, Int)+ mapFoldFn fp (_, tkns) idx = V.foldl' (foldFn fp) idx tkns++ foldFn+ :: FilePath+ -> Map.Map Text (FilePath, Int)+ -> DisplayToken+ -> Map.Map Text (FilePath, Int)+ foldFn fp idx (DisplayToken (DTHeading _ t) l _) = Map.insert t (fp, lcOffset l) idx+ foldFn _ idx _ = idx++tokenProcessing :: TChan IDEEvent -> MVar Int -> IORef (V.Vector DisplayToken) -> IO ()+tokenProcessing ideEventRef cursorRef tokensRef = forever $ do+ cursor <- takeMVar cursorRef+ modifyIORef tokensRef (V.map (mapFn cursor))+ liftIO $ atomically $ writeTChan ideEventRef IDEDraw+ where+ mapFn :: Int -> DisplayToken -> DisplayToken+ mapFn cursor dt = if cursor >= (lcOffset $ dtLocation dt) && cursor <= (dtOffsetEnd dt)+ then case dt of+ DisplayToken (DTLink _ n) l e -> DisplayToken (DTLink True n) l e+ _ -> dt+ else case dt of+ DisplayToken (DTLink _ n) l e -> DisplayToken (DTLink False n) l e+ _ -> dt++parsedDocContent :: IO (Map.Map FilePath (Text, V.Vector DisplayToken))+parsedDocContent = UI.Widgets.foldM foldFn mempty docContent+ where+ foldFn+ :: Map.Map FilePath (Text, V.Vector DisplayToken)+ -> (FilePath, BS.ByteString)+ -> IO (Map.Map FilePath (Text, V.Vector DisplayToken))+ foldFn idx (fp,sbs) = do+ parseHelp (decodeUtf8 sbs) >>= \case+ Right tokens -> do+ checkSamples fp tokens+ pure $ Map.insert fp (convertToDisplay (V.fromList tokens)) idx+ Left err -> do+ putStrLn err+ error $ "Error while parsing help file: " <> fp++checkSamples :: FilePath -> [HToken] -> IO ()+checkSamples fp = CM.mapM_ checkOneSample . fmap tkRaw+ where+ checkOneSample :: HTokenRaw -> IO ()+ checkOneSample (Code _ tks) = parseEither @Program tks >>= \case+ Right _ -> pure ()+ Left err -> do+ error ("Error parsing code in help file:"<> fp <> ":" <> show err)+ checkOneSample _ = pure ()++helpWidget :: WidgetC m => [Text] -> TChan IDEEvent -> m (WRef HelpWidget)+helpWidget builtins ideEventRef = do+ -- The help window+ let helpWidgetDimDistrbution = \case+ 1 -> [1]+ 2 -> [0, 1]+ _ -> error "Unsupported widget count"+ let helpWidgetTopDimDistrbution = \case+ 2 -> [0.1, 0.9]+ _ -> error "Unsupported widget count"+ cursorRef <- liftIO $ newMVar @Int 0+ searchResultRef <- liftIO newEmptyMVar+ searchChan <- liftIO (newTChanIO @SearchPage)+ helpLayoutRef <- layoutWidget Vertical helpWidgetDimDistrbution Nothing+ helptopLayoutRef <- layoutWidget Horizontal helpWidgetTopDimDistrbution Nothing+ helpSearchInput <- editor (\_ -> pure []) Nothing++ tokensRef <- liftIO $ newIORef @(V.Vector DisplayToken) V.empty++ tokenProcessingThreadId <- liftIO $ forkIO (tokenProcessing ideEventRef cursorRef tokensRef)++ helpContent <- editor (\_ -> pure []) (Just $ SomeTokenStream (V.toList <$> readIORef tokensRef))+ modifyWRef helpSearchInput (\hw -> hw { ewParams = (ewParams hw) { epLineNos = False} })+ modifyWRef helpContent (\hw -> hw { ewShowVirtualCursor = True, ewParams = (ewParams hw) { epLineNos = False} })+ addWidget helptopLayoutRef "helpsearchinput" helpSearchInput+ (newWRef nullWidget) >>= addWidget helptopLayoutRef "helpsearchspacer"+ addWidget helpLayoutRef "helpsearch" helptopLayoutRef+ addWidget helpLayoutRef "helpcontent" helpContent+ docs <- liftIO parsedDocContent+ let docIndex = buildIndex docs+ void $ liftIO $ forkIO (searchThread docIndex searchChan searchResultRef)+ let builtinOperators = "=" : ((\x -> toSource $ toEnum @Operator x) <$> [0 .. fromEnum $ maxBound @Operator])+ let builtinKeywords = (\x -> toSource $ toEnum @Keyword x) <$> [0 .. fromEnum $ maxBound @Keyword]+ let linksInDocs = Set.fromList $ collectLinks docs+ let linksInIndex = Set.fromList $ Map.keys docIndex+ let builtinSymbols = Set.fromList builtins+ let missingLinks = Set.difference linksInDocs linksInIndex+ let missingDocs = Set.difference (Set.difference builtinSymbols (Set.fromList (builtinKeywords <> builtinOperators))) linksInIndex+ if (Set.size(missingLinks) > 0)+ then error $ "Missing links in document: " <> show missingLinks+ else do+ if (Set.size(missingDocs) > 0)+ then error $ "Missing documents for: " <> show missingDocs+ else do+ r <- newWRef $ HelpWidget helpSearchInput helpContent helpLayoutRef True cursorRef (Just tokenProcessingThreadId) ideEventRef tokensRef docs docIndex Nothing [] searchResultRef searchChan+ loadPage r (Right "toc.md")+ pure r
+ src/IDE/Help/Contents.hs view
@@ -0,0 +1,12 @@+module IDE.Help.Contents where++import qualified Data.ByteString as BS+import Data.FileEmbed++docContent :: [(FilePath, BS.ByteString)]+docContent = $(embedDir "docs")++-- helpTokens :: TH.Q TH.Exp+-- helpTokens = TH.runIO $ do+-- tokens <- parseHelp (decodeUtf8 docContent)+-- TH.lift tokens
+ src/IDE/Help/Parser.hs view
@@ -0,0 +1,193 @@+module IDE.Help.Parser where++import Control.Applicative+import Control.Monad+import Data.Text as T+import qualified Data.Vector as V+import System.Console.ANSI (Color(..))++import Common+import qualified Compiler.Lexer.Tokens as CT+import Parser.Lib+import Parser.Parser++data DisplayTokenRaw+ = DTPlain Text+ | DTHeading Int Text+ | DTCode CT.Token+ | DTInlineCode CT.Token+ | DTLink Bool Text+ | DTNewLine+ deriving (Show, Eq)++instance ToSource DisplayTokenRaw where+ toSource = \case+ DTPlain t -> t+ DTHeading s t -> "\n" <> renderHeader s t+ DTCode t -> toSource t+ DTInlineCode t -> toSource t+ DTLink _ t -> t+ DTNewLine -> "\n"++underlineWith :: Text -> Text -> Text+underlineWith s t = t <> "\n" <> (T.replicate (T.length t) s)++renderHeader :: Int -> Text -> Text+renderHeader 1 t = underlineWith "*" t+renderHeader 2 t = underlineWith "_" t+renderHeader 3 t = underlineWith "=" t+renderHeader 4 t = underlineWith "-" t+renderHeader 5 t = "| " <> t+renderHeader _ t = t++data DisplayToken = DisplayToken { dtTr :: DisplayTokenRaw, dtLocation :: Location, dtOffsetEnd :: Int }+ deriving (Show, Eq)++convertToDisplay :: V.Vector HToken -> (Text, V.Vector DisplayToken)+convertToDisplay tokens = let (_, src, dt) = V.foldl' fn (0, "", V.empty) tokens in (src, dt)+ where+ fn :: (Int, Text, V.Vector DisplayToken) -> HToken -> (Int, Text, V.Vector DisplayToken)+ fn (lastOffset, srcin, tkns) a = let+ thisTokens = case tkRaw a of+ PlainText t -> V.singleton (DTPlain t)+ Heading _ s t -> V.singleton (DTHeading s t)+ Code _ t -> (V.cons DTNewLine (V.fromList (DTCode <$> t))) <> (V.singleton DTNewLine)+ InlineCode _ t -> V.fromList $ DTInlineCode <$> t+ Link t -> V.singleton (DTLink False t)+ NewLine -> V.singleton (DTNewLine)+ in V.foldl' fn2 (lastOffset, srcin, tkns) thisTokens++ fn2 :: (Int, Text, V.Vector DisplayToken) -> DisplayTokenRaw -> (Int, Text, V.Vector DisplayToken)+ fn2 (thisOffset, srcin, tkns) tkraw = let+ thisSize = T.length $ toSource tkraw+ in (thisOffset + thisSize, srcin <> (toSource tkraw), V.snoc tkns (DisplayToken tkraw (Location 0 0 thisOffset) (thisOffset + thisSize - 1)))++data HTokenRaw+ = PlainText Text+ | Heading Text Int Text+ | Code Text [CT.Token]+ | InlineCode Text [CT.Token]+ | Link Text+ | NewLine+ deriving (Show, Eq)++instance ToSource HTokenRaw where+ toSource (PlainText t) = t+ toSource (Heading t _ _) = t+ toSource (Code t _) = t+ toSource (InlineCode t _) = t+ toSource (Link t) = t+ toSource NewLine = "\n"++data HToken = HToken+ { tkRaw :: HTokenRaw+ , tkLocation :: Location+ , tkOffsetEnd :: Int+ } deriving (Show)++type HelpParser a = ParserM IO TextWithOffset a++parseChar :: (Char -> Bool) -> HelpParser Char+parseChar fn = ParserM "Help - Parse Char" $ \t ->+ case uncons (twText t) of+ Just (c, rst) -> case fn c of+ True -> pure (Right c, t { twText = rst, twLocation = moveCols (twLocation t) 1 })+ False -> pure (Left CantHandle, t)+ Nothing -> pure (Left CantHandle, t)++plainTextParser :: HelpParser HTokenRaw+plainTextParser = nameParser "Plain Text" $ (PlainText . T.pack) <$> (some $ parseChar fn)+ where+ fn '#' = False+ fn '`' = False+ fn '\n' = False+ fn _ = True++parseNLorStartWith :: HelpParser a -> HelpParser a+parseNLorStartWith pin = nlOrStart >> pin+ where+ nlOrStart = (void $ parseChar (\c -> c == '\n')) <|> (ParserM "Help - Steam start" $ \t ->+ case lcOffset $ twLocation t of+ 0 -> pure (Right (), t)+ _ -> pure (Left CantHandle, t))++linkParser :: HelpParser HTokenRaw+linkParser = do+ void $ pText "#link: "+ name <- some (parseChar (/= '#'))+ void $ pChar '#'+ pure $ Link (T.pack name)++headingParser :: Int -> HelpParser HTokenRaw+headingParser s = parseNLorStartWith (headingParser' s)++codeParser :: HelpParser HTokenRaw+codeParser = parseNLorStartWith codeParser'++headingParser' :: Int -> HelpParser HTokenRaw+headingParser' hs = ParserM "Help Heading" $ \t ->+ let+ prefix = (T.replicate hs "#") <> " "+ prefixLen = T.length prefix+ in if T.take prefixLen (twText t) == prefix+ then do+ let rst = T.drop prefixLen (twText t)+ let c = T.takeWhile (\c' -> c' /= '\n') rst+ let ln = T.length c+ pure (Right $ Heading (prefix <> c) hs c, t { twText = T.drop ln rst, twLocation = moveCols (twLocation t) (ln+prefixLen)})+ else pure (Left CantHandle, t)++codeParser' :: HelpParser HTokenRaw+codeParser' = ParserM "Help Code" $ \t ->+ case T.take 4 (twText t) of+ "```\n" -> do+ let rst = T.drop 4 (twText t)+ let (c, rst') = T.breakOn "\n```\n" rst+ let ln = T.length c+ runParserEither (parser @[CT.Token]) (toTextWithOffset c) >>= \case+ Left _ -> pure (Left CantHandle, t)+ Right tokens ->+ pure (Right $ Code ("```\n" <> c <> "\n```\n") tokens, t { twText = T.drop 5 rst', twLocation = moveCols (twLocation t) (ln+9)})+ _ -> pure (Left CantHandle, t)++inlineCodeParser :: HelpParser HTokenRaw+inlineCodeParser = nameParser "Help Inline Code" $ do+ void $ parseChar (== '`')+ tokens <- parser @[CT.Token]+ void $ parseChar (== '`')+ pure $ InlineCode ("`" <> (T.concat $ toSource <$> tokens) <> "`") tokens++instance HasParser HTokenRaw where+ parser = linkParser <|> (headingParser 1 <|> headingParser 2 <|> headingParser 3 <|> headingParser 4 <|> headingParser 5) <|> codeParser <|> inlineCodeParser <|> plainTextParser <|> newLineParser++instance HasInnerParseable HToken where+ type InnerToken HToken = HTokenRaw+ assemble = HToken++instance Highlightable DisplayToken where+ getTokenLoc (DisplayToken _ loc _) = loc+ highlight = highlightTokens+ pairWithTokens tokenStack startOffset source =+ genericPairWithTokens dtOffsetEnd dtLocation startOffset source tokenStack++highlightTokens :: (StyledText, Maybe DisplayToken) -> StyledText+highlightTokens (src, Nothing) = src+highlightTokens (src, Just (dtTr -> tk')) =+ case tk' of+ DTPlain _ -> src+ DTHeading _ _-> StyledText (Fg Green) [src]+ DTCode tk -> highlight @CT.Token (src, Just tk)+ DTInlineCode tk -> highlight @CT.Token (src, Just tk)+ DTLink True _ -> StyledText (Fg Red) [src]+ DTLink _ _ -> StyledText (Fg Blue) [src]+ DTNewLine -> src++newLineParser :: HelpParser HTokenRaw+newLineParser = nameParser "Help Newline" $ do+ void $ parseChar (== '\n')+ pure NewLine++parseHelp :: Text -> IO (Either String [HToken])+parseHelp t = runParserEither (some (parser @HToken)) (toTextWithOffset t) >>= \case+ Right r -> pure $ Right r+ Left err -> pure $ Left (show err)
+ src/IDE/IDE.hs view
@@ -0,0 +1,599 @@+module IDE.IDE where++import Common+import Compiler.Lexer+import Compiler.Parser+import Control.Concurrent+import Control.Concurrent.STM (TChan, TVar, atomically, dupTChan, modifyTVar,+ newTChan, newTChanIO, newTVarIO, readTChan,+ readTVar, readTVarIO, writeTChan, writeTVar)+import Control.Exception+import Control.Monad+import Data.IORef+import qualified Data.List as DL+import Data.Map as Map+import Data.Maybe+import qualified Data.Set as S+import Data.Text as T+import Data.Text.IO as T++import Compiler.AST.Program+import IDE.Common+import IDE.Help+import Interpreter+import Interpreter.Common+import Interpreter.Initialize+import Parser.Parser+import UI.Widgets+import UI.Widgets.AutoComplete+import UI.Widgets.Layout+import UI.Widgets.LogWidget+import UI.Widgets.WatchWidget++data IDEState = IDEState+ { idsDebugThreadId :: Maybe ThreadId+ , idsDebugIn :: Maybe (MVar DebugIn)+ , idsDebugOut :: Maybe (MVar DebugOut)+ , idsDebugThreadInput :: Maybe (TChan TerminalEvent)+ , idsCodeAutocompletions :: [(Text, Text)]+ , idsCodeParseError :: Maybe (Location, Text)+ , idsKeyInputReciever :: Maybe SomeKeyInputWidget+ }++ideStartState :: IDEState+ideStartState = IDEState Nothing Nothing Nothing Nothing [] Nothing Nothing++type Clipboard = (Text -> IO (), IO (Maybe Text))++type IDEM a = WidgetM IO a++editorId :: Text+editorId = "editor"++watchWidgetId :: Text+watchWidgetId = "watch"++extractBuiltIns :: IO ([(Text, Text)], [(Text, Text)])+extractBuiltIns = do+ debugIn <- newEmptyMVar+ debugOut <- newEmptyMVar+ sdlWindowsRef <- newIORef []+ scope <- isGlobalScope . snd <$> runStateT loadBuiltIns (emptyIs sdlWindowsRef debugIn debugOut (error "Input stream not available"))+ let keywords = (\x -> let s = toSource $ toEnum @Keyword x in (s, s)) <$> [0 .. fromEnum $ maxBound @Keyword]+ let builtIns = DL.foldl' extractOneDoc [] (Map.assocs scope)+ pure $ (keywords, builtIns)+ where+ extractOneDoc :: [(Text, Text)] -> (ScopeKey, Value) -> [(Text, Text)]+ extractOneDoc in_ (SkIdentifier (unIdentifer ->ide), BuiltIn (BuiltinVal (ObjectValue m))) =+ in_ <> ((\k -> let a = ide <> "." <> k in (a, a)) <$> Map.keys m)+ extractOneDoc in_ (SkIdentifier ide, BuiltIn (BuiltinCallWithDoc s)) =+ (unIdentifer ide, T.concat [+ unIdentifer ide,+ "(",+ T.intercalate ", " ((\(l, r) -> T.concat [l, ": ", r]) <$> extractDoc s),+ ")"+ ]+ ) : in_+ extractOneDoc in_ (SkIdentifier ide, BuiltIn (BuiltinCall _)) = (unIdentifer ide, unIdentifer ide) : in_+ extractOneDoc in_ (SkOperator op, _) = (toSource op, toSource op) : in_+ extractOneDoc in_ _ = in_++getAutocompleteSuggestions :: MonadIO m => TVar IDEState -> [(Text, Text)] -> Text -> m [(Text, Text)]+getAutocompleteSuggestions ideStateRef dict key = do+ acs <- liftIO $ idsCodeAutocompletions <$> readTVarIO ideStateRef+ pure $ Prelude.filter fn (acs <> dict)+ where+ fn :: (Text, Text) -> Bool+ fn (i, _) = T.isPrefixOf key i++getTerminalSize' :: IO Dimensions+getTerminalSize' = do+ s <- getTerminalSizeIO+ case s of+ Just (xs, ys) -> pure $ Dimensions xs ys+ _ -> error "Cannot read terminal size"++-- This thread reads the editor contents and try to parse into+-- tokens and ast. And then fills some autocomplete suggestions and+-- makes any parse error location.+codeProcessingThread :: IORef [Token] -> TChan IDEEvent -> MVar Text -> IO ()+codeProcessingThread tokensRef ideEventRef editorContentRef = forever $ do+ liftIO $ atomically $ writeTChan ideEventRef IDEReqEditorContent+ code <- takeMVar editorContentRef+ tokens <- tokenize code+ liftIO $ writeIORef tokensRef tokens+ mError <- parseEither @Program tokens >>= \case+ Left (ParseErrorWithParsed _ loc (FatalError a)) -> pure $ Just (loc, T.pack $ show a)+ Left (ParseErrorWithParsed _ _ (FatalErrorWithLocation loc fpe)) -> pure $ Just (loc, T.pack $ show fpe)+ _ -> pure Nothing+ liftIO $ atomically $ writeTChan ideEventRef $ IDEParseErrorUpdate mError+ liftIO $ atomically $ writeTChan ideEventRef $ IDEACUpdateIdentifiers $ S.toList $ S.fromList $ catMaybes $ filterIdentifiers <$> tokens+ wait 1+ where+ filterIdentifiers :: Token -> Maybe Text+ filterIdentifiers Token { tkRaw = (TkIdentifier (unIdentifer -> idf))} = Just idf+ filterIdentifiers _ = Nothing++-- | A type to differentiat debuging mode in IDE when input events+-- need to be fed to the interpreted program, and not to the IDE.+data InputRouting+ = RouteIDE+ | RouteProgram (TChan TerminalEvent)++instance Show InputRouting where+ show RouteIDE = "Route To IDE"+ show (RouteProgram _) = "Route To Program"++runIDE :: FilePath -> TChan TerminalEvent -> IO ()+runIDE filePath inputBroadcastChan = do+ dim <- getTerminalSize'+ content <- try (T.readFile filePath) >>= \case+ Right c -> pure c+ Left (_ :: SomeException) -> pure ""+ (keywords, builtIns) <- extractBuiltIns+ ideStateRef <- newTVarIO ideStartState+ ideEventsRef <- liftIO newTChanIO++ clipboardRef <- newIORef @(Maybe Text) Nothing+ let clipboard = (\t -> modifyIORef clipboardRef (\_ -> Just t), readIORef clipboardRef)+ editorContentMVar <- newEmptyMVar @Text++ tokensRef <- newIORef @[Token] []++ void $ forkIO $ codeProcessingThread tokensRef ideEventsRef editorContentMVar++ inputRouteToRef <- newTVarIO RouteIDE++ inputChan <- liftIO $ atomically $ dupTChan inputBroadcastChan++ void $ liftIO $ forkIO $ forever $ do+ (atomically $ readTVar inputRouteToRef) >>= appendLog+ atomically $ do+ kv <- readTChan inputChan+ readTVar inputRouteToRef >>= \case+ RouteIDE -> writeTChan ideEventsRef (IDETerminalEvent kv)+ RouteProgram chan -> writeTChan chan kv++ void $ runWidgetM $ do++ -- The editor+ editorRef <- editor (getAutocompleteSuggestions ideStateRef (keywords <> ((\(a, b) -> (a <>"()", b)) <$> builtIns))) (Just $ SomeTokenStream (readIORef tokensRef))+ setContent editorRef content+ liftIO $ atomically $ modifyTVar ideStateRef (\ids -> ids { idsKeyInputReciever = Just $ SomeKeyInputWidget editorRef })++ -- Watch widget+ watchWidgetRef <- watchWidget++ let dimensionDistributionFn = \case+ 1 -> [1]+ 2 -> [0.85, 0.15]+ 3 -> [0.70, 0.15, 0.15]+ a -> error $ "Unsupported widget count:" <> show a++ watchAndLogLayout <- layoutWidget Horizontal dimensionDistributionFn Nothing+ logRef <- logWidget+ insertLog logRef "Welcome to S.P.A.D.E: The Simple Programming And Debugging Environment."+ insertLog logRef "By Sandeep.C.R"+ addWidget watchAndLogLayout "log" logRef+ addWidget watchAndLogLayout watchWidgetId watchWidgetRef++ helpWidgetRef <- helpWidget ((Prelude.head . T.split (== '.'). fst) <$> builtIns) ideEventsRef+ -- The autocomplete widget+ ac <- autoComplete+ modifyWRef editorRef (\ed -> ed { ewAutocompleteWidget = Just $ SomeWidgetRef ac })++ -- The Outermost layout+ layoutRef <- layoutWidget Vertical dimensionDistributionFn (Just $ SomeKeyInputWidget editorRef)+ modifyWRef layoutRef (\lw -> lw { lowFloatingContent = Just $ SomeWidgetRef ac })++ addWidget layoutRef editorId editorRef+ addWidget layoutRef "helpwidget" helpWidgetRef+ addWidget layoutRef "watchandlog" watchAndLogLayout+ setVisibility helpWidgetRef False+ setTextFocus layoutRef editorId++ -- The menu+ let menu = Menu+ [ ("File", SubMenu ["Save (F6)", "Beautify", "Exit"])+ , ("Edit", SubMenu ["Cut", "Copy", "Paste", "Select All"])+ , ("Run", SubMenu ["Run (F5)", "Step (Ctrl+F8)"])+ , ("Windows", SubMenu ["Clear log"])+ , ("Help", SubMenu ["Contents"])+ ] Nothing+ menuContainerRef <- menuContainer (SomeWidgetRef layoutRef) menu (selectionHandler ideEventsRef)++ modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim })++ modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef })++ -- Initial screen paint+ csInitialize dim+ draw menuContainerRef+ csDraw++ -- A snippet that refresh the screen.+ let ideRedraw = do+ csClear+ draw menuContainerRef+ csDraw++ let getActiveEditor = do+ (getVisibility editorRef) >>= \case+ True -> pure editorRef+ _ -> getVisibility helpWidgetRef >>= \case+ True -> hwContentWidget <$> (readWRef helpWidgetRef)+ _ -> error "No visible editor"+ let+ launchProgram = do+ source <- getContent editorRef+ liftIO (compileEither source >>= \case+ Right p -> do+ debugIn <- newEmptyMVar+ debugOut <- newEmptyMVar+ programInputChan <- liftIO $ atomically newTChan+ threadId <- forkOS (void $ do+ liftIO $ atomically $ do+ writeTVar inputRouteToRef (RouteProgram programInputChan)+ interpret debugIn debugOut programInputChan p)+ atomically $+ modifyTVar ideStateRef+ (\idestate ->+ idestate+ { idsDebugThreadId = Just threadId+ , idsDebugIn = Just debugIn+ , idsDebugOut = Just debugOut+ , idsDebugThreadInput = Just programInputChan+ })+ pure $ Right (threadId, debugIn, debugOut, programInputChan)+ Left err -> do+ pure $ Left (hReadable err)+ )++ uiLoop ideEventsRef (\case+ IDEToggleHelp -> do+ getVisibility helpWidgetRef >>= \case+ True -> do+ setVisibility helpWidgetRef False+ setVisibility editorRef True+ setVisibility watchAndLogLayout True+ modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef })+ liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget editorRef }))+ False -> do+ setVisibility helpWidgetRef True+ setVisibility editorRef False+ setVisibility watchAndLogLayout False+ modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget helpWidgetRef })+ liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget helpWidgetRef }))+ d <- getScreenBounds+ csInitialize d+ draw menuContainerRef+ csDraw+ pure True+ IDESave -> do+ c <- getContent editorRef+ liftIO $ T.writeFile filePath c+ insertLog logRef ("Saved to " <> (T.pack filePath) <>".")+ pure True+ IDEEdit Copy -> do+ ew <- getActiveEditor >>= readWRef+ case ewSelection ew of+ Just (r1, r2) -> let+ contents = ewContent ew+ removeLength = (r2 - r1 + 1)+ copyContent = T.take (removeLength + 1) (T.drop r1 contents)+ in liftIO $ (fst clipboard) copyContent+ Nothing -> pass+ pure True+ IDEEdit Cut -> do+ modifyWRefM editorRef (\ew -> case ewSelection ew of+ Just (r1, r2) -> let+ contents = ewContent ew+ (p1, p2) = T.splitAt r1 contents+ removeLength = (r2 - r1 + 1)+ cutContent = T.take removeLength p2+ in do+ liftIO $ (fst clipboard) cutContent+ let newCursor = max 0 (r1 - 1)+ pure $ putCursor Nothing newCursor $ ew { ewSelection = Nothing, ewContent = p1 <> (T.drop removeLength p2) }+ Nothing -> pure ew+ )+ ideRedraw+ pure True+ IDEEdit Paste -> do+ modifyWRefM editorRef (\ew -> do+ let+ contents = ewContent ew+ (p1, p2) = T.splitAt (ewCursor ew) contents+ (liftIO (snd clipboard)) >>= \case+ Nothing -> pure ew+ Just insertContent ->+ pure $ putCursor Nothing (ewCursor ew + T.length insertContent) $ ew { ewContent = p1 <> insertContent <> p2 }+ )+ ideRedraw+ pure True+ IDEEdit SelectAll -> do+ modifyWRef editorRef (\ew -> ew { ewSelection = Just (0, (T.length $ ewContent ew) - 1) })+ ideRedraw+ pure True+ IDEClearLog -> do+ modifyWRef logRef (\lw -> lw { lwContent = [], lwScrollOffset = 0 })+ pure True+ IDEBeautify -> do+ insertLog logRef "Formatting..."+ code <- getContent editorRef+ (liftIO $ compileEither @Program code) >>= \case+ Right a -> do+ setContent editorRef (T.strip $ toSource a)+ liftIO $ atomically $ writeTChan ideEventsRef IDEDraw+ Left (ParseErrorWithParsed _ _ e) -> insertLog logRef ("Parse error:" <> T.pack (show e))+ pure True+ IDEDraw -> do+ d <- getScreenBounds+ csInitialize d+ draw menuContainerRef+ csDraw+ pure True+ IDEACUpdateIdentifiers acs -> do+ liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeAutocompletions = (\x -> (x, x)) <$> acs }))+ pure True+ IDEParseErrorUpdate mError -> do+ liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeParseError = mError }))+ idestate <- liftIO $ readTVarIO ideStateRef+ case idsCodeParseError idestate of+ Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc })+ Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing })+ ideRedraw+ pure True+ IDEReqEditorContent -> do+ c <- getContent editorRef+ liftIO $ void $ putMVar editorContentMVar c+ pure True+ IDEExit -> do+ pure False+ IDERun -> do+ (\x' -> (idsDebugThreadId x', idsDebugIn x', idsDebugOut x', idsDebugThreadInput x')) <$> liftIO (readTVarIO ideStateRef) >>= \case+ -- If we are in a debug session, just run to completion.+ (Just threadId, Just debugIn, Just debugOut, Just programInputChan) -> do+ insertLog logRef "Continuing debug session to end..."+ executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just Run) threadId debugIn debugOut programInputChan+ _ -> do+ -- Or else launch a new run of the program.+ clearscreen+ setCursorPosition 0 0+ launchProgram >>= \case+ Right (threadId, debugIn, debugOut, programInputChan) -> do+ insertLog logRef "Starting..."+ executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just Run) threadId debugIn debugOut programInputChan+ Left err -> do+ insertLog logRef $ "Compile Error:" <> err+ liftIO $ atomically $ writeTChan ideEventsRef IDEDraw+ pure True+ IDEStep -> do+ csSetCursorPosition 0 0+ (\x' -> (idsDebugThreadId x', idsDebugIn x', idsDebugOut x', idsDebugThreadInput x')) <$> liftIO (readTVarIO ideStateRef) >>= \case+ -- A debugging session exists already.+ -- Send the step command, wait for updated state to arrive.+ (Just threadId, Just debugIn, Just debugOut, Just programInputChan) ->+ executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just StepIn) threadId debugIn debugOut programInputChan+ _ -> do+ -- No debugging session exist. Launch one.+ launchProgram >>= \case+ Right (threadId, debugIn, debugOut, programInputChan) -> do+ insertLog logRef "Starting..."+ executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef Nothing threadId debugIn debugOut programInputChan+ Left err -> insertLog logRef $ "Compile Error:" <> err+ pure True+ IDETerminalEvent (TerminalResize w h) -> do+ let dim' = Dimensions w h+ csInitialize dim'+ modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim' })+ draw menuContainerRef+ adjustScrollOffset editorRef+ draw menuContainerRef+ csDraw+ pure True+ IDEDebugUpdate mds -> do+ case mds of+ Just ds -> do+ modifyWRef editorRef (\ew -> ew { ewReadOnly = True, ewDebugLocation = Just $ dsLocation ds, ewCursor = lcOffset (dsLocation ds) - 1 })+ modifyWRef watchWidgetRef (\ww -> ww { wwVisible = True, wwContent = scopeToWatchItems $ dsScope ds })+ case dsCurrenEvaluation ds of+ Just cv -> insertLog logRef ("Evaluating: " <> cv)+ Nothing -> pass++ Nothing -> do+ modifyWRef editorRef (\ew -> ew { ewReadOnly = False, ewDebugLocation = Nothing })+ modifyWRef watchWidgetRef (\ww -> ww { wwVisible = False })+ liftIO $ atomically $ writeTChan ideEventsRef IDEDraw+ pure True+ IDETerminalEvent (TerminalKey ev) -> case ev of+ KeyChar True _ _ 'c' -> pure False+ KeyChar True _ _ 'C' -> pure False+ k -> do+ updateMenuOnKey menuContainerRef k >>= \case+ True -> pure ()+ False -> shortcutsHandler ideEventsRef k >>= \case+ True -> pure ()+ False -> idsKeyInputReciever <$> (liftIO $ readTVarIO ideStateRef) >>= \case+ Just (SomeKeyInputWidget w) -> handleInput w k+ Nothing -> pure ()+ idestate <- liftIO $ readTVarIO ideStateRef+ case idsCodeParseError idestate of+ Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc })+ Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing })+ ideRedraw+ pure True+ )+ where+ executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventRef ideStateRef mcmd threadId debugIn debugOut programInputChan = do+ case mcmd of+ Just cmd -> do+ liftIO $ do+ -- Empty out any pending debug message, and discard it.+ void $ tryTakeMVar debugOut+ -- before sending in a debug input.+ atomically $ writeTVar inputRouteToRef (RouteProgram programInputChan)+ putMVar debugIn cmd+ _ -> pure ()+ (liftIO (catch (do+ dd <- takeMVar debugOut+ atomically $ writeTVar inputRouteToRef RouteIDE+ pure dd+ )+ -- Possibly handle a control-c triggered by user to break+ -- a long runing operation.+ (\(e :: SomeException) -> do+ killThread threadId+ pure $ Errored $ T.pack $ show e+ )+ )) >>= \case+ -- Update the IDE debug state with the received debug state.+ DebugData ds -> do+ liftIO $ atomically $ writeTChan ideEventRef (IDEDebugUpdate $ Just ds)+ Errored err -> do+ liftIO $ atomically $ modifyTVar ideStateRef (\i -> ideStartState { idsKeyInputReciever = idsKeyInputReciever i })+ modifyWRef editorRef (\ew -> ew { ewReadOnly = False })+ insertLog logRef err+ liftIO $ atomically $ do+ writeTChan ideEventRef (IDEDebugUpdate Nothing)+ Finished -> do+ modifyWRef editorRef (\ew -> ew { ewReadOnly = False })+ liftIO $ atomically $ modifyTVar ideStateRef (\i -> ideStartState { idsKeyInputReciever = idsKeyInputReciever i })+ insertLog logRef "Finished program"+ liftIO $ atomically $ do+ writeTChan ideEventRef (IDEDebugUpdate Nothing)++updateMenuOnKey :: WidgetC m => WRef MenuContainerWidget -> KeyEvent -> m Bool+updateMenuOnKey ref kv = do+ w <- readWRef ref+ case (kv, menuActive $ mcwMenu w) of+ (KeyCtrl _ _ _ Esc, Just _) -> do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Nothing }})+ setCursorVisibility True+ pure True+ (KeyChar _ _ True c, _) -> do+ foldM_ (\x (n, _) -> case T.uncons (T.toLower n) of+ Nothing -> pure $ x + 1+ Just (c1, _) ->+ if c == c1+ then do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, 0) }})+ setCursorVisibility False+ pure $ x + 1+ else+ pure $ x + 1) 0 (menuItems $ mcwMenu w)+ pure True+ (KeyCtrl _ _ _ ArrowLeft, Just (x, _))+ | x > 0 -> do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x - 1, 0) }})+ pure True+ | otherwise -> do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (Prelude.length (menuItems $ mcwMenu w) - 1, 0) }})+ pure True++ (KeyCtrl _ _ _ ArrowRight, Just (x, _)) -> do+ let menuItemsLength = Prelude.length $ menuItems $ mcwMenu w+ let newX = x + 1+ if newX < menuItemsLength+ then do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (newX, 0) }})+ pure True+ else do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (0, 0) }})+ pure True++ (KeyCtrl _ _ _ ArrowUp, Just (x, y))+ | y > 0 -> do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, y - 1) }})+ pure True+ | otherwise -> do+ case getSubmenuAt (mcwMenu w) x of+ Nothing -> pure True+ Just (SubMenu smi) -> do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, Prelude.length smi - 1) }})+ pure True++ (KeyCtrl _ _ _ ArrowDown, Just (x, y)) -> do+ case getSubmenuAt (mcwMenu w) x of+ Just (SubMenu smi) -> do+ let newY = y + 1+ if newY < (Prelude.length smi)+ then do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, newY) }})+ pure True+ else do+ modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, 0) }})+ pure True+ Nothing -> pure True+ (KeyCtrl _ _ _ Return, Just (x, y)) -> do+ (mcwSelectionHandler w) ref (x, y)+ setCursorVisibility True+ pure True+ _ -> pure False++scopeToWatchItems :: Scope -> [(Text, Text)]+scopeToWatchItems s = Map.foldlWithKey' (\o k v ->+ let+ vKey = case k of+ SkIdentifier i -> unIdentifer i+ SkOperator op -> T.pack $ show op+ vText = case v of+ StringValue t -> Just t+ NumberValue (NumberInt t) -> Just $ T.pack $ show t+ NumberValue (NumberFractional t) -> Just $ T.pack $ show t+ BoolValue t -> Just $ T.pack $ show t+ ArrayValue t -> Just $ T.pack $ show t+ ObjectValue t -> Just $ T.pack $ show t+ _ -> Nothing++ in case vText of+ Just t -> (vKey, t) : o+ Nothing -> o+ ) [] s++selectionHandler+ :: forall m. WidgetC m+ => TChan IDEEvent+ -> WRef MenuContainerWidget+ -> (Int, Int)+ -> m ()+selectionHandler ideEventsRef ref selection = do+ case selection of+ (0, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDESave+ (0, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEBeautify+ (0, 2) -> liftIO $ atomically $ writeTChan ideEventsRef IDEExit+ (1, 0) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Cut)+ (1, 1) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Copy)+ (1, 2) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Paste)+ (1, 3) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit SelectAll)+ (2, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDERun+ (2, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEStep+ (3, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEClearLog+ (4, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEToggleHelp+ _ -> pass+ modifyWRef ref (\mcw -> mcw { mcwMenu = (mcwMenu mcw) { menuActive = Nothing } })+ liftIO $ atomically $ writeTChan ideEventsRef IDEDraw++shortcutsHandler+ :: forall m. WidgetC m+ => TChan IDEEvent+ -> KeyEvent+ -> m Bool+shortcutsHandler ideEventRef kv = do+ case kv of+ KeyCtrl _ _ _ (Fun 6) -> do+ liftIO $ atomically $ writeTChan ideEventRef IDESave+ pure True++ KeyCtrl _ _ _ (Fun 1) -> do+ liftIO $ atomically $ writeTChan ideEventRef IDEToggleHelp+ pure True++ KeyCtrl True _ _ (Fun 8) -> do+ liftIO $ atomically $ writeTChan ideEventRef IDEStep+ pure True++ KeyCtrl _ _ _ (Fun 5) -> do+ liftIO $ atomically $ writeTChan ideEventRef IDERun+ pure True+ _ -> pure False
+ src/Interpreter.hs view
@@ -0,0 +1,62 @@+module Interpreter where++import Prelude hiding (map)++import Control.Concurrent.MVar+import Control.Exception (SomeException, displayException)+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Catch (catch)+import Data.IORef (newIORef)+import Data.Map as M hiding (map)+import Data.Text as T hiding (index, map)++import Compiler.AST.Program+import Control.Monad.State.Strict+import Interpreter.Common+import Interpreter.Initialize+import Interpreter.Interpreter+import Interpreter.Lib.SDL+import UI.Widgets.Common++interpret_ :: TChan TerminalEvent -> Program -> IO InterpreterState+interpret_ teventChan prg = do+ debugIn <- newEmptyMVar+ debugOut <- newEmptyMVar+ sdlWindowsRef <- newIORef []+ let istate = emptyIs sdlWindowsRef debugIn debugOut teventChan+ interpret' (istate { isRunMode = NormalMode }) prg++interpret :: MVar DebugIn -> MVar DebugOut -> TChan TerminalEvent -> Program -> IO InterpreterState+interpret debugIn debugOut teventsChan prg = do+ sdlWindowsRef <- newIORef []+ interpret' (emptyIs sdlWindowsRef debugIn debugOut teventsChan) prg++interpret' :: InterpreterState -> Program -> IO InterpreterState+interpret' istate prg = snd <$> do+ let debugOut = isDebugOut istate+ flip runStateT istate $ catch (do+ loadBuiltIns+ interpretPassOne prg+ interpretPassTwo prg+ cleanupSDL+ liftIO $ putMVar debugOut Finished+ ) (\(e :: SomeException) -> do+ cleanupSDL+ liftIO $ putMVar debugOut (Errored $ T.pack $ displayException e))++interpretPassOne :: Program -> InterpretM ()+interpretPassOne x = mapM_ (\a -> fn a) x+ where+ fn :: ProgramStatement -> InterpretM ()+ fn (FunctionDefStatement fdef@(FunctionDef name _ _)) = modify $ mapGlobalScope $+ \s -> insert (SkIdentifier name) (ProcedureValue fdef) s+ fn _ = pure ()++interpretPassTwo :: Program -> InterpretM ()+interpretPassTwo x = mapM_ (\a -> fn a) x+ where+ fn :: ProgramStatement -> InterpretM ()+ fn (FunctionDefStatement (FunctionDef _ _ _)) = pure ()+ fn (NakedStatement fs) = void $ executeStatement fs+ fn (TopLevelComment _) = pure ()
+ src/Interpreter/Common.hs view
@@ -0,0 +1,556 @@+module Interpreter.Common where++import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TMVar+import Control.Exception+import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)+import qualified Data.ByteString as BS+import Data.IORef+import Data.Kind (Type)+import Data.List.NonEmpty+import Data.Map as M+import Data.Maybe (isJust)+import Data.Proxy+import Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import Data.Word+import Foreign.C.Types+import GHC.OverloadedLabels+import GHC.TypeLits+import SDL hiding (Keycode, Scancode)+import qualified SDL as SDL+import qualified SDL.Mixer as SDLM++import Common+import UI.Widgets.Common+import Compiler.AST.Program+import Compiler.Lexer++audioSampleCount :: Int+audioSampleCount = 44100++type Sample = SDLM.Chunk++data BuiltinVal+ = BuiltinCallWithDoc SomeBuiltin+ | BuiltinCall BuiltInFn+ | BuiltinVal Value++instance Show BuiltinVal where+ show _ = "_builtin_"++newtype SDLKeyboardStateCallback = SDLKeyboardStateCallback (SDL.Scancode -> Bool)++data SDLValue+ = Renderer SDL.Renderer+ | Color (V4 Int)+ | Keycode SDL.Keycode+ | Scancode SDL.Scancode+ | KeyboardState SDLKeyboardStateCallback+ | SoundSample Sample++instance Show SDLValue where+ show (Keycode k) = "(SDL_KEY)" <> show k+ show (Scancode k) = "(SDL_SCANCODE)" <> show k+ show (KeyboardState _) = "(SDL_KEYBOARD_STATE)"+ show (Color _) = "(SDL_COLOR)"+ show (Renderer _) = "(SDL_RENDERER)"+ show (SoundSample _) = "(SDL_SOUND)"++data Number+ = NumberInt IntType+ | NumberFractional FloatType+ deriving Show++negateValue :: Number -> Number+negateValue (NumberInt x) = NumberInt $ negate x+negateValue (NumberFractional x) = NumberFractional $ negate x++numberBinaryFn :: (forall n. Num n => n -> n -> n) -> Number -> Number -> Number+numberBinaryFn fn n1 n2 = case (n1, n2) of+ (NumberInt x, NumberInt y) -> NumberInt $ fn x y+ (NumberFractional x, NumberFractional y) -> NumberFractional $ fn x y+ (NumberInt x, NumberFractional y) -> NumberFractional $ fn (realToFrac x) y+ (NumberFractional x, NumberInt y) -> NumberFractional $ fn x (realToFrac y)++numberBinaryFractionalFn :: (forall n. Fractional n => n -> n -> n) -> Number -> Number -> Number+numberBinaryFractionalFn fn n1 n2 = case (n1, n2) of+ (NumberInt x, NumberInt y) -> NumberFractional $ fn (realToFrac x) (realToFrac y)+ (NumberFractional x, NumberFractional y) -> NumberFractional $ fn x y+ (NumberInt x, NumberFractional y) -> NumberFractional $ fn (realToFrac x) y+ (NumberFractional x, NumberInt y) -> NumberFractional $ fn x (realToFrac y)++instance Eq Number where+ (NumberInt n1) == (NumberInt n2) = n1 == n2+ (NumberFractional n1) == (NumberFractional n2) = n1 == n2+ (NumberFractional n1) == (NumberInt n2) = n1 == (realToFrac n2)+ (NumberInt n1) == (NumberFractional n2) = (realToFrac n1) == n2++instance Ord Number where+ compare (NumberInt x) (NumberInt y) = compare x y+ compare (NumberFractional x) (NumberFractional y) = compare x y+ compare (NumberInt x) (NumberFractional y) = compare (realToFrac x) y+ compare (NumberFractional x) (NumberInt y) = compare x (realToFrac y)++data UnNamedFn = UnNamedFn (Maybe (NonEmpty Identifier)) ExpressionWithLoc+ deriving Show++data ThreadInfo = ThreadInfo ThreadId (TMVar (Either SomeException Value))++instance Show ThreadInfo where+ show _ = "(ThreadInfo)"++newtype ChannelRef = ChannelRef (TChan Value)++instance Show ChannelRef where+ show _ = "(ConcurrencyChannel)"++newtype MutableRef = MutableRef (TMVar Value)++instance Show MutableRef where+ show _ = "(MutableRef)"++data Value+ = StringValue Text+ | NumberValue Number+ | BoolValue Bool+ | BytesValue BS.ByteString+ | ArrayValue (V.Vector Value)+ | ObjectValue (Map Text Value)+ | ProcedureValue FunctionDef+ | UnnamedFnValue UnNamedFn+ | BuiltIn BuiltinVal+ | SDLValue SDLValue+ | ThreadRef ThreadInfo+ | Channel ChannelRef+ | Ref MutableRef+ | ErrorValue Text+ | Void+ deriving Show++instance Ord Value where+ compare (NumberValue x) (NumberValue y) = compare x y+ compare _ _ = error "Cannot be compared"++data ProcResult+ = ProcReturn Bool Value -- Bool indicates tail call+ | ProcBreak+ | ProcContinue++instance Eq Value where+ (StringValue t) == (StringValue v) = t == v+ (NumberValue t) == (NumberValue v) = t == v+ (BoolValue t) == (BoolValue v) = t == v+ (BytesValue t) == (BytesValue v) = t == v+ (ArrayValue t) == (ArrayValue v) = t == v+ (ObjectValue t) == (ObjectValue v) = t == v+ (SDLValue (Keycode kc1)) == (SDLValue (Keycode kc2)) = kc1 == kc2+ (ProcedureValue _) == _ = error "Procedures cannot be compared"+ _ == (ProcedureValue _) = error "Procedures cannot be compared"+ (BuiltIn _) == _ = error "Procedures cannot be compared"+ _ == (BuiltIn _) = error "Procedures cannot be compared"+ Void == _ = error "Void cannot be compared"+ _ == Void = error "Void cannot be compared"+ _ == _ = False++data ScopeKey+ = SkIdentifier Identifier+ | SkOperator Operator+ deriving (Ord, Eq)++instance Show ScopeKey where+ show (SkIdentifier i) = unpack $ unIdentifer i+ show (SkOperator i) = show i++type Scope = Map ScopeKey Value++data RunMode+ = NormalMode+ | DebugMode+ deriving Show++data DebugIn+ = AddWatch Text+ | StepIn+ | StepOver+ | Run+ deriving Show++data StepMode+ = SingleStep+ | Continue+ deriving Show++data DebugState = DebugState+ { dsScope :: Scope+ , dsLocation :: Location+ , dsCurrenEvaluation :: Maybe Text+ } deriving Show++data DebugOut+ = Finished+ | Errored Text+ | DebugData DebugState+ deriving Show++data InterpreterState = InterpreterState+ { isLocal :: [Scope]+ , isRunMode :: RunMode+ , isGlobalScope :: Scope+ , isDefaultRenderer :: Maybe SDL.Renderer+ , isAccelerated :: Maybe Bool+ , isDefaultWindow :: Maybe SDL.Window+ , isSDLWindows :: IORef [SDL.Window] -- We need these to cleanup any SDL windows after an exception.+ , isDebugIn :: MVar DebugIn+ , isDebugOut :: MVar DebugOut+ , isStepMode :: StepMode+ , isThreadId :: Maybe ThreadId+ , isTerminalEventChan :: TChan TerminalEvent+ }++instance Show InterpreterState where+ show InterpreterState {..} = show (isJust isDefaultWindow)++emptyIs :: IORef [SDL.Window] -> MVar DebugIn -> MVar DebugOut -> TChan TerminalEvent -> InterpreterState+emptyIs sdlWindowsRef din dout inputChan = InterpreterState mempty DebugMode mempty Nothing Nothing Nothing sdlWindowsRef din dout SingleStep Nothing inputChan++mapLocal :: ([Scope] -> [Scope]) -> (InterpreterState -> InterpreterState)+mapLocal fn = \is -> is { isLocal = fn $ isLocal is }++mapGlobalScope :: (Scope -> Scope) -> (InterpreterState -> InterpreterState)+mapGlobalScope fn = \is -> is { isGlobalScope = fn $ isGlobalScope is }++type InterpretM a = forall m. (MonadCatch m, MonadIO m) => StateT InterpreterState m a++instance {-# OVERLAPPING #-} (MonadCatch m, MonadIO m) => MonadIO (StateT InterpreterState m) where+ liftIO act = lift $ liftIO @m (wrapSomeException IOError act)++type BuiltInFnWithDoc s = NamedArgs s -> InterpretM (Maybe Value)+type BuiltInFn = [Value] -> InterpretM (Maybe Value)++data Callback+ = CallbackUnNamed UnNamedFn+ | CallbackNamed Identifier++instance FromValue (M.Map Text Value) where+ fromValue (ObjectValue t) = t+ fromValue a = throwErr $ UnexpectedType ("object", a)+ typeName = "object"++instance FromValue ThreadInfo where+ fromValue (ThreadRef t) = t+ fromValue a = throwErr $ UnexpectedType ("thread_ref", a)+ typeName = "thread_ref"++instance FromValue ChannelRef where+ fromValue (Channel t) = t+ fromValue a = throwErr $ UnexpectedType ("concurrency_channel", a)+ typeName = "concurrency_channel"++instance FromValue MutableRef where+ fromValue (Ref t) = t+ fromValue a = throwErr $ UnexpectedType ("mutable_reference", a)+ typeName = "mutable_reference"++instance FromValue BytesOrText where+ fromValue (StringValue t) = BTText t+ fromValue (BytesValue t) = BTBytes t+ fromValue a = throwErr $ UnexpectedType ("filepath", a)+ typeName = "filepath"++instance FromValue FilePath where+ fromValue (StringValue t) = T.unpack t+ fromValue a = throwErr $ UnexpectedType ("filepath", a)+ typeName = "filepath"++instance FromValue Sample where+ fromValue (SDLValue (SoundSample s)) = s+ fromValue a = throwErr $ UnexpectedType ("soundsample", a)+ typeName = "soundsample"++instance FromValue Text where+ fromValue (StringValue t) = t+ fromValue a = throwErr $ UnexpectedType ("string", a)+ typeName = "string"++instance FromValue BS.ByteString where+ fromValue (BytesValue b) = b+ fromValue a = throwErr $ UnexpectedType ("bytes", a)+ typeName = "bytes"++instance FromValue SDL.Scancode where+ fromValue (SDLValue (Scancode sc)) = sc+ fromValue a = throwErr $ UnexpectedType ("scancode", a)+ typeName = "scancode"++instance FromValue SDLKeyboardStateCallback where+ fromValue (SDLValue (KeyboardState cb)) = cb+ fromValue a = throwErr $ UnexpectedType ("callback", a)+ typeName = "keyboardstate"++instance FromValue Callback where+ fromValue (UnnamedFnValue un) = CallbackUnNamed un+ fromValue (ProcedureValue (FunctionDef idf _ _)) = CallbackNamed idf+ fromValue a = throwErr $ UnexpectedType ("callback", a)+ typeName = "callback"++class FromValue a where+ fromValue :: Value -> a+ typeName :: Text++instance FromValue SDL.Keycode where+ fromValue (SDLValue (Keycode keycode)) = keycode+ fromValue a = throwErr $ UnexpectedType ("keycode", a)+ typeName = "keycode"++instance FromValue Int where+ fromValue (NumberValue (NumberInt i)) = fromIntegral i+ fromValue (NumberValue (NumberFractional i)) = round i+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "integer"++instance FromValue SDLM.Channel where+ fromValue = fromIntegral . fromValue @Int+ typeName = "channel"++instance FromValue Bool where+ fromValue (BoolValue b) = b+ fromValue a = throwErr $ UnexpectedType ("boolean", a)+ typeName = "boolean"++instance FromValue Integer where+ fromValue (NumberValue (NumberInt i)) = i+ fromValue (NumberValue (NumberFractional i)) = round i+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "integer"++instance FromValue Double where+ fromValue (NumberValue (NumberInt i)) = realToFrac i+ fromValue (NumberValue (NumberFractional i)) = i+ fromValue a = throwErr $ UnexpectedType ("fractional", a)+ typeName = "fractional"++instance FromValue a => FromValue (V.Vector a) where+ fromValue (ArrayValue v) = V.map fromValue v+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "list of " <> (typeName @a)++instance FromValue Number where+ fromValue (NumberValue i) = i+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "number"++instance FromValue CInt where+ fromValue (NumberValue (NumberInt i)) = fromIntegral i+ fromValue (NumberValue (NumberFractional i)) = fromIntegral $ round i+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "number"++instance FromValue Value where+ fromValue = id+ typeName = "any"++mkPoint :: CInt -> CInt -> SDL.Point SDL.V2 CInt+mkPoint x y = SDL.P (SDL.V2 x y)++instance FromValue (VS.Vector (SDL.Point V2 CInt)) where+ fromValue (ArrayValue v) = VS.fromList $ V.toList $ fn <$> v+ where+ fn :: Value -> SDL.Point V2 CInt+ fn (ArrayValue (V.toList -> [v1, v2])) = mkPoint (fromValue v1) (fromValue v2)+ fn a = throwErr $ UnexpectedType ("list(2)", a)+ fromValue a = throwErr $ UnexpectedType ("list", a)+ typeName = "list"++instance FromValue (V.Vector (Number, Number)) where+ fromValue (ArrayValue v) = V.map fn v+ where+ fn (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1)+ fn a = throwErr $ UnexpectedType ("list with two values", a)+ fromValue a = throwErr $ UnexpectedType ("list", a)+ typeName = "list"++instance FromValue Word8 where+ fromValue = \case+ (NumberValue (NumberInt i)) -> fromInt i+ (NumberValue (NumberFractional i)) -> fromInt (round i)+ a -> throwErr $ UnexpectedType ("number", a)+ where+ fromInt i = if (fromIntegral i) <= (maxBound @Word8) then fromIntegral i else throwErr $ CustomRTE "Number too large to be converted to a byte"+ typeName = "number"++newtype Variadic = Variadic [Value]++instance FromValue Variadic where+ fromValue v = Variadic [v]+ typeName = "variadic argument"++newtype NamedArg (s :: Symbol) a = NamedArg a++instance KnownSymbol s => IsLabel s (a -> NamedArg s a) where+ fromLabel = NamedArg++data NamedArgs (s :: [(Symbol, Type)]) where+ EmptyArgs :: NamedArgs '[]+ (:>) :: (KnownSymbol s, FromValue a) => NamedArg s a -> NamedArgs r -> NamedArgs ('(s, a) ': r)+infixr 8 :>++class KnownArgs a where+ toArgDoc :: [(Text, Text)]+ toArgs :: [Value] -> NamedArgs a++instance {-# OVERLAPPING #-} KnownSymbol n => KnownArgs '[ '(n, Variadic)] where+ toArgDoc = [("variadic", "Value")]+ toArgs x = NamedArg (Variadic x) :> EmptyArgs++instance KnownArgs '[] where+ toArgDoc = []+ toArgs [] = EmptyArgs+ toArgs _ = error "Unexpected arguments"++instance (KnownSymbol n, FromValue t, KnownArgs s) => KnownArgs (('(n, t) ': s)) where+ toArgDoc = (pack $ symbolVal (Proxy @n), typeName @t) : toArgDoc @s+ toArgs [] = throwErr $ BadArguments ((pack $ symbolVal (Proxy @n)) <> " of type " <> typeName @t, "No argument")+ toArgs (ErrorValue err : _) = throwErr $ CustomRTE err+ toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst)++instance FromValue a => FromValue (Maybe a) where+ fromValue v = Just $ fromValue v+ typeName = (typeName @a) <> "(optional)"++instance {-# OVERLAPPING #-} (KnownSymbol n, FromValue t, KnownArgs s) => KnownArgs (('(n, Maybe t) ': s)) where+ toArgDoc = (pack $ symbolVal (Proxy @n), typeName @(Maybe t)) : toArgDoc @s+ toArgs [] = (NamedArg (Nothing :: Maybe t)) :> (toArgs @s [])+ toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst)++data SomeBuiltin where+ SomeBuiltin :: KnownArgs s => (NamedArgs s -> InterpretM (Maybe Value)) -> SomeBuiltin++extractDoc :: SomeBuiltin -> [(Text, Text)]+extractDoc (SomeBuiltin (_ :: NamedArgs s -> InterpretM (Maybe Value))) = toArgDoc @s++wrapSomeException :: (Text -> RuntimeError) -> IO a -> IO a+wrapSomeException fn act =+ flip catch (\(e :: SomeException) -> case fromException @AsyncException e of+ Just _ -> throwM e+ _ -> case fromException @IOException e of+ Just _ -> throwM $ fn $ T.pack $ displayException e+ Nothing -> throwM e) act++instance HReadable (Either RuntimeError ProgramError) where+ hReadable (Right x) = hReadable x+ hReadable (Left x) = hReadable x++data RuntimeErrorWithLoc = RuntimeErrorWithLoc (Either RuntimeError ProgramError) Location++instance HReadable RuntimeErrorWithLoc where+ hReadable (RuntimeErrorWithLoc msg loc) = "Runtime error: " <> (hReadable msg) <> ", at: " <> (hReadable loc)++instance Show RuntimeErrorWithLoc where+ show = T.unpack . hReadable++instance Exception RuntimeErrorWithLoc where++data ProgramError+ = SymbolNotFound Text+ | UnexpectedType (Text, Value)+ | MissingProcedureReturn+ | EmptyScopeStack+ | BadArguments (Text, Text)++data RuntimeError+ = IOError Text+ | SDLError Text+ | ListIndexOutOfBounds Int+ | KeyNotFound Text+ | CustomRTE Text++instance Show RuntimeError where+ show = T.unpack . hReadable++instance Show ProgramError where+ show = T.unpack . hReadable++instance HReadable ProgramError where+ hReadable = \case+ SymbolNotFound s -> "Unknown symbol reference: '" <> s <>"'"+ UnexpectedType (e, f) -> case f of+ ErrorValue t -> t+ _ -> "Unexpected type, expected " <> e <> ", but got: " <> (T.pack $ show f)+ MissingProcedureReturn -> "Function or callback call did not return a value as expected"+ EmptyScopeStack -> "Stack was unexpectedly empty"+ BadArguments (e, f) -> "Unexpected argument count or type, expected: " <> e <> ", but got: " <> f++instance HReadable RuntimeError where+ hReadable = \case+ IOError t -> "Input/Output error: " <> t+ SDLError t -> "SDL error: " <> t+ ListIndexOutOfBounds t -> "Out of bound access of a list at index: " <> (T.pack $ show t)+ KeyNotFound t -> "Non-existing key access in dictionary at key: " <> t+ CustomRTE t -> "Run time error: " <> t++throwBadArgs :: [Value] -> Text -> InterpretM (Maybe Value)+throwBadArgs v' m = throwBadArgs' v' [] m+ where+ throwBadArgs' :: [Value] -> [Value] -> Text -> InterpretM (Maybe Value)+ throwBadArgs' (v@(ErrorValue _): _) _ _ = pure $ Just v+ throwBadArgs' (v : rst) bargs msg = throwBadArgs' rst (v:bargs) msg+ throwBadArgs' [] bargs msg = throwErr $ BadArguments (msg, T.pack $ show $ Prelude.reverse bargs)++data BytesOrText+ = BTBytes BS.ByteString+ | BTText Text+ deriving Show++instance Exception RuntimeError where+ displayException e = T.unpack $ hReadable e++instance Exception ProgramError where+ displayException e = T.unpack $ hReadable e++class InterpreterException a where+ throwErr :: (Exception e) => e -> a++instance InterpreterException a where+ throwErr r = throw r++instance {-# OVERLAPPING #-} InterpreterException ([] a) where+ throwErr r = throw r++instance {-# OVERLAPPING #-} MonadThrow m => InterpreterException (StateT InterpreterState m a) where+ throwErr = throwM++waitMillisec' :: Number -> IO ()+waitMillisec' number = case number of+ NumberFractional v -> do+ threadDelay (round $ v * 1000000)+ NumberInt v -> do+ threadDelay (fromInteger $ v * 1000000)++insertBuiltInVal :: ScopeKey -> Value -> InterpretM ()+insertBuiltInVal sk val = modify $ mapGlobalScope fn+ where+ fn :: Scope -> Scope+ fn s = M.insert sk (BuiltIn $ BuiltinVal val) s++insertBuiltIn :: ScopeKey -> BuiltInFn -> InterpretM ()+insertBuiltIn sk val = modify $ mapGlobalScope fn+ where+ fn :: Scope -> Scope+ fn s = M.insert sk (BuiltIn $ BuiltinCall val) s++insertBuiltInWithDoc :: ScopeKey -> SomeBuiltin -> InterpretM ()+insertBuiltInWithDoc sk val = modify $ mapGlobalScope fn+ where+ fn :: Scope -> Scope+ fn s = M.insert sk (BuiltIn $ BuiltinCallWithDoc val) s++insertBinding :: ScopeKey -> Value -> InterpretM ()+insertBinding sk val = modify fn+ where+ fn :: InterpreterState -> InterpreterState+ fn is@(InterpreterState { isGlobalScope, isLocal }) = case isLocal of+ [] -> is { isGlobalScope = M.insert sk val isGlobalScope }+ (s : rst) -> is { isLocal = (M.insert sk val s) : rst }
+ src/Interpreter/Initialize.hs view
@@ -0,0 +1,123 @@+module Interpreter.Initialize where++import Prelude hiding (map)++import Compiler.Lexer+import Interpreter.Common+import Interpreter.Interpreter+import Interpreter.Lib.Math+import Interpreter.Lib.Misc+import Interpreter.Lib.Concurrency+import Interpreter.Lib.SDL++loadBuiltIns :: InterpretM ()+loadBuiltIns = do+ insertBuiltIn (SkOperator OpStar) multiplication+ insertBuiltIn (SkOperator OpPlus) addition+ insertBuiltIn (SkOperator OpMinus) substraction+ insertBuiltIn (SkOperator OpDivide) division+ insertBuiltIn (SkOperator OpEquality) (comparison (==))+ insertBuiltIn (SkOperator OpLT) (comparison (<))+ insertBuiltIn (SkOperator OpGT) (comparison (>))+ insertBuiltIn (SkOperator OpLTE) (comparison (<=))+ insertBuiltIn (SkOperator OpGTE) (comparison (>=))+ insertBuiltIn (SkOperator OpNotEquality) (comparison (/=))+ insertBuiltIn (SkOperator OpAnd) (boolean (&&))+ insertBuiltIn (SkOperator OpOr) (boolean (||))++ -- Containers+ insertBuiltInWithDoc (SkIdentifier $ Identifier "size") (SomeBuiltin valueSize)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "contains") (SomeBuiltin contains)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "haskey") (SomeBuiltin haskey)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "filter") (SomeBuiltin filter_)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "drop") (SomeBuiltin arrayDrop)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "take") (SomeBuiltin arrayTake)++ -- Time+ insertBuiltInWithDoc (SkIdentifier $ Identifier "timestamp") (SomeBuiltin builtInTimestamp)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "wait") (SomeBuiltin waitMillisec)++ -- Keyboard+ insertBuiltInWithDoc (SkIdentifier $ Identifier "getkey") (SomeBuiltin waitForKey)++ -- Files+ insertBuiltInWithDoc (SkIdentifier $ Identifier "readfile") (SomeBuiltin builtInReadFile)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "readtextfile") (SomeBuiltin builtInReadTextFile)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "writefile") (SomeBuiltin builtInWriteFile)++ -- Math+ insertBuiltInWithDoc (SkIdentifier $ Identifier "mod") (SomeBuiltin builtInMod)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "random") (SomeBuiltin builtInRandom)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "sin") (SomeBuiltin builtInSin)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "cos") (SomeBuiltin builtInCos)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "tan") (SomeBuiltin builtInTan)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "asin") (SomeBuiltin builtInASin)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "acos") (SomeBuiltin builtInACos)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "atan") (SomeBuiltin builtInATan)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "sum") (SomeBuiltin builtInSum)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "round") (SomeBuiltin builtInRound)++ -- List/Map+ insertBuiltInWithDoc (SkIdentifier $ Identifier "insertleft") (SomeBuiltin builtInArrayInsertLeft)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "insertright") (SomeBuiltin builtInArrayInsertRight)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "head") (SomeBuiltin builtInHead)++ -- Misc+ insertBuiltInWithDoc (SkIdentifier $ Identifier "try") (SomeBuiltin builtInTry)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "jsondecode") (SomeBuiltin builtInJSONParse)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "jsonencode") (SomeBuiltin builtInJSONSerialize)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "decodeutf8") (SomeBuiltin builtInDecodeUTF8Bytes)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "encodeutf8") (SomeBuiltin builtInEncodeUTF8Bytes)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "not") (SomeBuiltin not')+ insertBuiltInWithDoc (SkIdentifier $ Identifier "debug") (SomeBuiltin builtInDebug)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "inspect") (SomeBuiltin builtInInspect)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "println") (SomeBuiltin printValLn)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "print") (SomeBuiltin printVal)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "inputline") (SomeBuiltin builtinInputLine)++ -- SDL Sound+ insertBuiltInWithDoc (SkIdentifier $ Identifier "maketone") (SomeBuiltin builtInMakeTone)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "makesound") (SomeBuiltin builtInMakeSoundSample)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "loadsound") (SomeBuiltin builtInMakeSoundSampleFromFile)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "playsound") (SomeBuiltin builtInPlaySoundSample)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "setvolume") (SomeBuiltin builtInSetSampleVolume)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "setvolumelr") (SomeBuiltin builtInSetSampleLRVolume)++ -- SDL Graphics+ insertBuiltInWithDoc (SkIdentifier $ Identifier "graphicswindow") (SomeBuiltin createGraphicsWindow)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "graphics") (SomeBuiltin createGraphicsFullscreen)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "point") (SomeBuiltin drawPoint)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "points") (SomeBuiltin drawPoints)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "line") (SomeBuiltin drawLine)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "lines") (SomeBuiltin drawLines)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "circle") (SomeBuiltin drawCircle)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "box") (SomeBuiltin drawBox)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "drawscreen") (SomeBuiltin draw)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "setcolor") (SomeBuiltin setDrawColor)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "clearscreen") (SomeBuiltin clear)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "getwindowsize") (SomeBuiltin getWindowSize)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "setlogicalsize") (SomeBuiltin setLogicalSize)++ -- SDL Keyboard+ insertBuiltInWithDoc (SkIdentifier $ Identifier "getkeypresses") (SomeBuiltin getKeys)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "waitforkey") (SomeBuiltin waitForSDLKey)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "getkeystate") (SomeBuiltin getKeyboardState)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "inkeystate") (SomeBuiltin wasKeyDownIn)++ -- Concurrency+ insertBuiltInWithDoc (SkIdentifier $ Identifier "startthread") (SomeBuiltin builtInLaunchThread)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "killthread") (SomeBuiltin builtInKillThread)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "await") (SomeBuiltin builtInAwait)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "awaitresult") (SomeBuiltin builtInAwaitResult)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "newchannel") (SomeBuiltin builtInNewChannel)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "writechannel") (SomeBuiltin builtInWriteChannel)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "readchannel") (SomeBuiltin builtInReadChannel)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "newref") (SomeBuiltin builtInNewRef)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "readref") (SomeBuiltin builtInReadRef)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "writeref") (SomeBuiltin builtInWriteRef)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "modifyref") (SomeBuiltin builtInModifyRef)++ -- Constants+ insertBuiltInVal (SkIdentifier $ Identifier "keycodes") keycodes+ insertBuiltInVal (SkIdentifier $ Identifier "scancodes") scancodes+
+ src/Interpreter/Interpreter.hs view
@@ -0,0 +1,366 @@+module Interpreter.Interpreter where++import Prelude hiding (map)++import Control.Concurrent.MVar+import Control.Exception (throw)+import Control.Monad+import Control.Monad.Catch (catch)+import Control.Monad.Loops (iterateWhile)+import Data.Coerce+import qualified Data.List.NonEmpty as NE+import Data.Map as M hiding (map)+import Data.Text as T hiding (index, map)+import qualified Data.Vector as V++import Common+import Compiler.AST.FunctionStatement+import Compiler.AST.Program+import Compiler.Lexer+import Control.Monad.State.Strict+import Interpreter.Common++lookupScope :: ScopeKey -> InterpretM Value+lookupScope key = ((lookupInTopScope key . isLocal) <$> get) >>= \case+ Just v -> pure v+ Nothing -> ((M.lookup key . isGlobalScope) <$> get) >>= \case+ Just v -> pure v+ Nothing ->+ throwErr $ SymbolNotFound $ (pack $ show key)++lookupInTopScope :: ScopeKey -> [Scope] -> Maybe Value+lookupInTopScope _ [] = Nothing+lookupInTopScope key (h: _) = M.lookup key h++evaluateExpression :: ExpressionWithLoc -> InterpretM Value+evaluateExpression exp'@(ExpressionWithLoc _ loc) =+ catch+ (catch (executeDebugStepable exp') rteHandler) peHandler+ where+ rteHandler (r :: RuntimeError) = pure $ ErrorValue $ (hReadable r) <> " at " <> hReadable loc+ peHandler (r :: ProgramError) = throwErr @(InterpretM Value) $ RuntimeErrorWithLoc (Right r) loc++evaluateExpression_ :: Expression -> InterpretM Value+evaluateExpression_ (EParan le) = evaluateExpression le+evaluateExpression_ (ENegated le) = evaluateExpression le >>= \case+ NumberValue n -> pure $ NumberValue $ negateValue n+ x -> throwErr $ UnexpectedType ("Number", x)+evaluateExpression_ (ELiteral le) = evaluateLiteralExpression le+evaluateExpression_ (EVar idf) = lookupScope (SkIdentifier idf) >>= \case+ BuiltIn (BuiltinVal v) -> pure v+ v -> pure v+evaluateExpression_ (ESubscripted subscript) = evaluateSubscriptedExpr subscript+evaluateExpression_ (EConditional boolEx ex1 ex2) = evaluateExpression boolEx >>= \case+ BoolValue True -> evaluateExpression ex1+ BoolValue False -> evaluateExpression ex2+ x -> throwErr $ UnexpectedType ("Bool", x)+evaluateExpression_ (EOperator op e1 e2) = do+ evaluateFn (FnOp op) [e1, e2] False >>= \case+ Just v -> pure v+ Nothing -> throwErr MissingProcedureReturn+evaluateExpression_ (ECall iden exprs isTail) = evaluateFn (FnName iden) exprs isTail >>= \case+ Just v -> pure v+ Nothing -> throwErr MissingProcedureReturn+evaluateExpression_ (EUnnamedFn args expr) = pure $ UnnamedFnValue $ UnNamedFn args expr++popScope :: InterpretM ()+popScope = do+ (isLocal <$> get) >>= \case+ (_:rst) -> do+ modify (\is -> is { isLocal = rst })+ _ -> throwErr EmptyScopeStack++data FnId+ = FnOp Operator+ | FnName Identifier++evaluateCallback :: Callback -> [Value] -> InterpretM (Maybe Value)+evaluateCallback (CallbackUnNamed un) args = Just <$> evaluateUnnamedFn un args+evaluateCallback (CallbackNamed idf) args =+ evaluateProcedure (SkIdentifier idf) args++insertEmptyScope :: InterpretM ()+insertEmptyScope = modify $ mapLocal (\s -> mempty : s)++evaluateUnnamedFn :: UnNamedFn -> [Value] -> InterpretM Value+evaluateUnnamedFn (UnNamedFn Nothing expr) _ = evaluateExpression expr+evaluateUnnamedFn (UnNamedFn (Just (NE.toList -> argNames)) expr) argsVals = do+ insertEmptyScope+ zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) argsVals -- @TODO Check argument counts+ r <- evaluateExpression expr+ popScope+ pure r++evaluateProcedure :: ScopeKey -> [Value] -> InterpretM (Maybe Value)+evaluateProcedure sk args = do+ lookupScope sk >>= \case+ UnnamedFnValue un -> Just <$> evaluateUnnamedFn un args+ (ProcedureValue (FunctionDef _ argNames (NE.toList -> stms))) -> do+ insertEmptyScope+ zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) args -- @TODO Check argument counts+ executeStatements stms >>= \case+ ProcReturn False v -> do+ popScope+ pure $ Just v+ ProcReturn True v -> do+ -- Don't pop stack if the return was a tail call return+ -- because the stack was popped before entering the+ -- call.+ pure $ Just v+ ProcBreak -> do+ popScope+ pure Nothing+ ProcContinue -> do+ popScope+ pure Nothing+ (BuiltIn (BuiltinCall cb)) -> cb args+ (BuiltIn (BuiltinCallWithDoc (SomeBuiltin cb))) -> cb (toArgs args)+ a -> throwErr $ UnexpectedType ("Procedure", a)++evaluateFn :: FnId -> [ExpressionWithLoc] -> Bool -> InterpretM (Maybe Value)+evaluateFn fnId argsExps isTail = do+ let sk = case fnId of+ FnOp op -> SkOperator op+ FnName idf -> SkIdentifier idf+ args <- mapM (\x -> evaluateExpression x) argsExps+ when isTail popScope+ evaluateProcedure sk args++evaluateSubscriptedExpr :: SubscriptedExpression -> InterpretM Value+evaluateSubscriptedExpr (EArraySubscript expr indexExpr) = evaluateExpression expr >>= \case+ ArrayValue v -> evaluateExpression indexExpr >>= \case+ NumberValue (NumberInt i) -> do+ let index :: Int = fromIntegral i+ if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ ListIndexOutOfBounds index)+ a -> throwErr $ UnexpectedType ("Integer index", a)+ ObjectValue mp -> evaluateExpression indexExpr >>= \case+ StringValue key -> case M.lookup key mp of+ Just v -> pure v+ Nothing -> throwErr $ KeyNotFound (pack $ show key)+ a -> throwErr $ UnexpectedType ("Property index", a)+ a -> throwErr $ UnexpectedType ("Array/Map", a)+evaluateSubscriptedExpr (EPropertySubscript expr (unIdentifer -> key)) = evaluateExpression expr >>= \case+ ObjectValue mp -> case M.lookup key mp of+ Just v -> pure v+ Nothing -> throwErr $ KeyNotFound (pack $ show key)+ a -> throwErr $ UnexpectedType ("Map", a)++evaluateVar :: Subscript -> InterpretM Value+evaluateVar (NoSubscript idf) = lookupScope (SkIdentifier idf) >>= \case+ BuiltIn (BuiltinVal v) -> pure $ v+ v -> pure v+evaluateVar (SubscriptExpr sub expr) =+ -- Arrays are indexed from 1, not 0.+ evaluateExpression expr >>= \case+ NumberValue (NumberInt int) ->+ evaluateVar sub >>= \case+ ArrayValue v -> do+ let index :: Int = fromIntegral int+ if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ ListIndexOutOfBounds index)+ a -> throwErr $ UnexpectedType ("Array/Object", a)+ StringValue key -> lookupInMapVar sub key+ a -> throwErr $ UnexpectedType ("String/Integer container key", a)+evaluateVar (PropertySubscript sub idf) = lookupInMapVar sub (unIdentifer idf)++lookupInMapVar :: Subscript -> Text -> InterpretM Value+lookupInMapVar sub key = evaluateVar sub >>= \case+ ObjectValue mp -> case M.lookup key mp of+ Just v -> pure v+ Nothing -> throwErr $ KeyNotFound (pack $ show key)+ a -> throwErr $ UnexpectedType ("Expecting Object Looking for key: " <> (T.pack $ show sub) <> ":" <> key, a)++evaluateLiteralExpression :: LiteralExpression -> InterpretM Value+evaluateLiteralExpression (LAtomic (LitString t)) = pure $ StringValue t+evaluateLiteralExpression (LAtomic (LitBytes t)) = pure $ BytesValue t+evaluateLiteralExpression (LAtomic (LitNumber n)) = pure $ NumberValue $ NumberInt n+evaluateLiteralExpression (LAtomic (LitFloat f)) = pure $ NumberValue $ NumberFractional (realToFrac f)+evaluateLiteralExpression (LAtomic (LitBool b)) = pure $ BoolValue b+evaluateLiteralExpression (LArray l) = do+ v <- mapM (\x -> evaluateExpression x) l+ pure $ ArrayValue (V.fromList v)+evaluateLiteralExpression (LObject l) = do+ v <- mapM (\x -> evaluateExpression x) l+ pure $ ObjectValue v++voidStm :: () -> InterpretM (Maybe Value)+voidStm _ = pure Nothing++executeStatements :: [FunctionStatementWithLoc] -> InterpretM ProcResult+executeStatements x = foldM (\a1 a2 -> fn a1 a2) ProcContinue x+ where+ fn :: ProcResult -> FunctionStatementWithLoc -> InterpretM ProcResult+ fn (ProcReturn tc x') _ = pure $ ProcReturn tc x'+ fn ProcBreak _ = pure ProcBreak+ fn ProcContinue fs = executeStatement fs++modifyBinding :: Subscript -> Value -> InterpretM ()+modifyBinding (NoSubscript idf) val = insertBinding (SkIdentifier idf) val+modifyBinding (PropertySubscript sub (unIdentifer -> key)) val = do+ evaluateVar sub >>= \case+ ObjectValue v -> case M.lookup key v of+ Just _ -> modifyBinding sub (ObjectValue $ M.insert key val v)+ Nothing -> throwErr (KeyNotFound key)+ a -> throwErr $ UnexpectedType ("Map", a)+modifyBinding (SubscriptExpr sub expr) val = do+ evaluateVar sub >>= \case+ ArrayValue v -> evaluateExpression expr >>= \case+ NumberValue (NumberInt idx) -> do+ let index :: Int = fromIntegral idx+ if (index <= V.length v && index > 0)+ then modifyBinding sub (ArrayValue $ V.update v (V.fromList [(index - 1, val)]))+ else throwErr $ ListIndexOutOfBounds index+ a -> throwErr $ UnexpectedType ("Integer Index", a)+ ObjectValue v -> evaluateExpression expr >>= \case+ StringValue key -> case M.lookup key v of+ Just _ -> modifyBinding sub (ObjectValue $ M.insert key val v)+ Nothing -> throwErr (KeyNotFound key)+ a -> throwErr $ UnexpectedType ("String", a)+ a -> throwErr $ UnexpectedType ("Map", a)++class ToSource a => DebugStepable a b | a -> b where+ getLocation :: a -> Location+ execute :: a -> InterpretM b++instance DebugStepable FunctionStatementWithLoc ProcResult where+ getLocation (FunctionStatementWithLoc _ l) = l+ execute (FunctionStatementWithLoc fs _) = executeStatement_ fs++instance DebugStepable ExpressionWithLoc Value where+ getLocation (ExpressionWithLoc _ l) = l+ execute (ExpressionWithLoc exp' _) = evaluateExpression_ exp'++executeStatement :: FunctionStatementWithLoc -> InterpretM ProcResult+executeStatement fs@(FunctionStatementWithLoc _ loc) =+ catch+ (catch (executeDebugStepable fs) rteHandler) peHandler+ where+ rteHandler (r :: RuntimeError) = case r of+ CustomRTE msg -> throw (RuntimeErrorWithLoc (Left $ CustomRTE msg) loc)+ _ -> throw (RuntimeErrorWithLoc (Left r) loc)+ peHandler (r :: ProgramError) = throw (RuntimeErrorWithLoc (Right r) loc)++executeDebugStepable :: DebugStepable a b => a -> InterpretM b+executeDebugStepable dbs = do+ isRunMode <$> get >>= \case+ NormalMode -> do+ execute dbs+ DebugMode -> do+ isStepMode <$> get >>= \case+ Continue -> execute dbs+ SingleStep -> do+ isDebugOut <$> get >>= sendDebugOut+ isDebugIn <$> get >>= (liftIO . takeMVar) >>= \case+ Run -> do+ modify (\is -> is { isRunMode = NormalMode })+ execute dbs+ StepIn -> execute dbs+ AddWatch _ -> execute dbs+ StepOver -> do+ modify (\is -> is { isStepMode = Continue })+ r <- execute dbs+ modify (\is -> is { isStepMode = SingleStep })+ pure r+ where+ sendDebugOut debugOut = do+ currentScope <- isLocal <$> get >>= \case+ [] -> isGlobalScope <$> get+ (scope : _) -> pure scope+ let+ dd = DebugState currentScope (getLocation dbs) (Just $ toSource dbs)+ liftIO $ putMVar debugOut $ DebugData dd++executeStatement_ :: FunctionStatement -> InterpretM ProcResult+executeStatement_ (FnComment _) = pure ProcContinue+executeStatement_ (Let sub exp') = do+ sourceValue <- evaluateExpression exp'+ modifyBinding sub sourceValue+ pure ProcContinue+executeStatement_ (Call iden args) = do+ _ <- evaluateFn (FnName iden) args False+ pure ProcContinue+executeStatement_ (IfThen expr stms) = evaluateExpression expr >>= \case+ BoolValue True -> executeStatements (NE.toList stms)+ BoolValue _ -> pure ProcContinue+ a -> throwErr $ UnexpectedType ("Bool", a)+executeStatement_ (If expr stms1 stms2) = evaluateExpression expr >>= \case+ BoolValue b -> case b of+ True -> executeStatements (NE.toList stms1)+ False -> executeStatements (NE.toList stms2)++ a -> throwErr $ UnexpectedType ("Bool", a)+executeStatement_ (MultiIf expr stms1 elseifs mstms2) = evaluateExpression expr >>= \case+ BoolValue True -> executeStatements (NE.toList stms1)+ BoolValue False -> foldM executeElseIf Nothing elseifs >>= \case+ Just r -> pure r+ Nothing -> case mstms2 of+ Just stms2 -> executeStatements (NE.toList stms2)+ Nothing -> pure ProcContinue+ a -> throwErr $ UnexpectedType ("Bool", a)+ where+ executeElseIf a@(Just _) _ = pure a+ executeElseIf Nothing (bexpr, stms) = evaluateExpression bexpr >>= \case+ BoolValue True -> Just <$> executeStatements (NE.toList stms)+ BoolValue False -> pure Nothing+ a -> throwErr $ UnexpectedType ("Bool", a)++executeStatement_ (Return eloc@(ExpressionWithLoc { elExpression = ECall idf args _ })) =+ -- TCO+ evaluateExpression (eloc { elExpression = ECall idf args True }) >>= pure . ProcReturn True+executeStatement_ (Return expr) = evaluateExpression expr >>= pure . ProcReturn False+executeStatement_ Break = pure ProcBreak+executeStatement_ (Loop (NE.toList -> stms)) = iterateWhile (\case+ ProcBreak -> False+ ProcContinue -> True+ ProcReturn _ _ -> False) (executeStatements stms)++executeStatement_ (While exprBool (NE.toList -> stms)) = do+ r <- iterateWhile (\case+ ProcBreak -> False+ ProcContinue -> True+ ProcReturn _ _ -> False)+ (evaluateExpression exprBool >>= \case+ BoolValue True -> executeStatements stms+ BoolValue False -> pure ProcBreak+ a -> throwErr $ UnexpectedType ("Bool", a))+ case r of+ ProcBreak -> pure ProcContinue+ a -> pure a+executeStatement_ (For iden exprFrom exprTo (NE.toList -> stms)) = evaluateExpression exprFrom >>= \case+ NumberValue (NumberInt start) -> evaluateExpression exprTo >>= \case+ NumberValue (NumberInt end) -> do+ let+ fn :: ProcResult -> IntType -> InterpretM ProcResult+ fn ProcContinue current = do+ insertBinding (SkIdentifier iden) (NumberValue $ NumberInt $ current)+ executeStatements stms+ fn r _ = pure r+ foldM (\a1 a2 -> fn a1 a2) ProcContinue [start .. end] >>= \case+ ProcReturn tc v -> pure $ ProcReturn tc v+ _ -> pure ProcContinue+ a -> throwErr $ UnexpectedType ("Int", a)+ a -> throwErr $ UnexpectedType ("Int", a)++executeStatement_ (ForEach iden expr (NE.toList -> stms)) = evaluateExpression expr >>= \case+ ObjectValue map -> do+ foldM (\a1 (k, v) -> fn a1 (ObjectValue $ M.fromList [("key", StringValue k), ("value", v)])) ProcContinue (M.assocs map) >>= \case+ ProcReturn tc v -> pure $ ProcReturn tc v+ _ -> pure ProcContinue+ ArrayValue values -> do+ V.foldM (\a1 a2 -> fn a1 a2) ProcContinue values >>= \case+ ProcReturn tc v -> pure $ ProcReturn tc v+ _ -> pure ProcContinue+ a -> throwErr $ UnexpectedType ("Array/Object", a)+ where+ fn :: ProcResult -> Value -> InterpretM ProcResult+ fn ProcContinue current = do+ insertBinding (SkIdentifier iden) current+ executeStatements stms+ fn r _ = pure r++filter_ :: BuiltInFnWithDoc '[ '("list", V.Vector Value), '("callback", Callback)]+filter_ ((coerce -> v1) :> (coerce -> callback) :> _) =+ (\x -> Just $ ArrayValue x) <$> V.filterM fn v1+ where+ fn v = evaluateCallback callback [v] >>= \case+ Just (BoolValue x) -> pure x+ _ -> throwErr $ CustomRTE "Callback returned a non-bool value"
+ src/Interpreter/Lib/Concurrency.hs view
@@ -0,0 +1,79 @@+module Interpreter.Lib.Concurrency where++import Control.Concurrent+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TMVar+import Control.Exception (AsyncException(..), SomeException, catch, toException)+import Control.Monad.IO.Class+import Control.Monad.State.Strict+import Data.Coerce++import Interpreter.Common+import Interpreter.Interpreter++builtInLaunchThread :: BuiltInFnWithDoc '[ '("callback_thread", Callback), '("callback_arg", Value) ]+builtInLaunchThread ((coerce -> (processCb :: Callback)) :> (coerce -> threadArg) :> EmptyArgs) = do+ istate <- get+ liftIO $ do+ resultRef <- newEmptyTMVarIO+ threadId <- forkIO $ flip catch (asynExHandler resultRef) $ do+ (r, _) <- flip runStateT istate (evaluateCallback processCb [threadArg])+ atomically $ putTMVar resultRef $ case r of+ Just r' -> Right r'+ Nothing -> Left (toException MissingProcedureReturn)+ pure $ Just $ ThreadRef $ ThreadInfo threadId resultRef+ where+ asynExHandler :: TMVar (Either SomeException Value) -> AsyncException -> IO ()+ asynExHandler ref e = atomically $ putTMVar ref $ Left $ toException e++builtInKillThread :: BuiltInFnWithDoc '[ '("thread_result", ThreadInfo) ]+builtInKillThread ((coerce -> (ThreadInfo threadId _)) :> EmptyArgs) = do+ liftIO $ killThread threadId+ pure Nothing++builtInAwait :: BuiltInFnWithDoc '[ '("thread_result", ThreadInfo) ]+builtInAwait ((coerce -> (ThreadInfo _ pmvar)) :> EmptyArgs) = do+ void $ liftIO $ atomically $ readTMVar pmvar+ pure Nothing++builtInAwaitResult :: BuiltInFnWithDoc '[ '("thread_result", ThreadInfo) ]+builtInAwaitResult ((coerce -> (ThreadInfo _ pmvar)) :> EmptyArgs) =+ (liftIO $ atomically $ readTMVar pmvar) >>= \case+ Right x -> pure $ Just x+ Left e -> throwErr e++builtInNewChannel :: BuiltInFnWithDoc '[]+builtInNewChannel _ = (pure . Channel . ChannelRef) <$> liftIO newTChanIO++builtInWriteChannel :: BuiltInFnWithDoc '[ '("channel_ref", ChannelRef), '("value", Value)]+builtInWriteChannel ((coerce -> (ChannelRef chan)) :> (coerce -> val) :> _) = do+ liftIO $ atomically $ writeTChan chan val+ pure Nothing++builtInReadChannel :: BuiltInFnWithDoc '[ '("channel_ref", ChannelRef)]+builtInReadChannel ((coerce -> (ChannelRef chan)) :> _) =+ Just <$> (liftIO $ atomically $ readTChan chan)++builtInNewRef :: BuiltInFnWithDoc '[ '("init_value", Value) ]+builtInNewRef ((coerce -> (v :: Value)) :> EmptyArgs) = do+ ref <- liftIO $ newTMVarIO v+ pure $ Just $ Ref $ MutableRef ref++builtInWriteRef :: BuiltInFnWithDoc '[ '("ref", MutableRef), '("new_value", Value) ]+builtInWriteRef ((coerce -> (MutableRef ref)) :> (coerce -> v) :> EmptyArgs) = do+ void $ liftIO $ atomically $ swapTMVar ref v+ pure Nothing++builtInReadRef :: BuiltInFnWithDoc '[ '("ref", MutableRef) ]+builtInReadRef ((coerce -> (MutableRef ref)) :> EmptyArgs) = do+ v <- liftIO $ atomically $ readTMVar ref+ pure $ Just v++builtInModifyRef :: BuiltInFnWithDoc '[ '("ref", MutableRef), '("callback", Callback) ]+builtInModifyRef ((coerce -> (MutableRef ref)) :> (coerce -> callback) :> EmptyArgs) = do+ v <- liftIO $ atomically $ takeTMVar ref+ evaluateCallback callback [v] >>= \case+ Just v' -> liftIO $ atomically $ putTMVar ref v'+ Nothing -> throwErr MissingProcedureReturn+ pure Nothing
+ src/Interpreter/Lib/Math.hs view
@@ -0,0 +1,58 @@+module Interpreter.Lib.Math where++import Control.Monad.IO.Class+import Data.Coerce+import Data.Vector as V++import Common+import Interpreter.Common+import System.Random++builtInSum :: BuiltInFnWithDoc '[ '("numbers", Vector Number)]+builtInSum ((coerce -> numbers) :> _)+ = let+ addFn = numberBinaryFn (+)+ in pure $ Just $ NumberValue $ V.foldl' addFn (NumberInt 0) numbers++builtInMod :: BuiltInFnWithDoc '[ '("divident", IntType), '("divisor", IntType)]+builtInMod ((coerce -> divid) :> (coerce -> divis) :> _)+ = pure $ Just $ NumberValue $ NumberInt $ mod divid divis++builtInRound :: BuiltInFnWithDoc '[ '("value", FloatType)]+builtInRound ((coerce -> (number :: FloatType)) :> _)+ = pure $ Just $ NumberValue $ NumberInt $ round $ number++builtInRandom :: BuiltInFnWithDoc '[ '("start_rage", IntType), '("end_range", IntType)]+builtInRandom ((coerce -> start) :> (coerce -> end) :> _) = do+ r <- liftIO $ randomRIO @IntType (start, end)+ pure $ Just $ NumberValue $ NumberInt r++builtInSin :: BuiltInFnWithDoc '[ '("angle", FloatType)]+builtInSin ((coerce -> angle) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (sin (degreeToRadian angle))++builtInCos :: BuiltInFnWithDoc '[ '("angle", FloatType)]+builtInCos ((coerce -> angle) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (cos (degreeToRadian angle))++builtInTan :: BuiltInFnWithDoc '[ '("angle", FloatType)]+builtInTan ((coerce -> angle) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (tan (degreeToRadian angle))++builtInASin :: BuiltInFnWithDoc '[ '("arg", FloatType)]+builtInASin ((coerce -> v) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (radianToDegree $ asin v)++builtInACos :: BuiltInFnWithDoc '[ '("arg", FloatType)]+builtInACos ((coerce -> v) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (radianToDegree $ acos v)++builtInATan :: BuiltInFnWithDoc '[ '("arg", FloatType)]+builtInATan ((coerce -> v) :> _) = do+ pure $ Just $ NumberValue $ NumberFractional (radianToDegree $ atan v)++radianToDegree :: FloatType -> FloatType+radianToDegree x = (x/pi*180)++degreeToRadian :: FloatType -> FloatType+degreeToRadian x = (x/180*pi)
+ src/Interpreter/Lib/Misc.hs view
@@ -0,0 +1,234 @@+module Interpreter.Lib.Misc where++import Control.Monad.IO.Class+import Control.Concurrent.STM+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import Data.Text.Encoding+import qualified Data.ByteString.Lazy as BSL+import Data.Coerce+import qualified Data.Scientific as S+import Data.Map as M+import Text.Hex (encodeHex)+import Data.HashMap.Strict as HM+import Data.Text as T+import Data.Text.IO as T+import Data.Time.Clock.System+import Data.Vector as V+import qualified System.IO as S+import Control.Monad.State.Strict as SM++import UI.Widgets.Common+import Interpreter.Common++printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)]+printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do+ liftIO $ do+ UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals)+ T.putStrLn ""+ S.hFlush S.stdout+ pure Nothing++printVal :: BuiltInFnWithDoc '[ '("value", Variadic)]+printVal ((coerce -> (Variadic vals)) :> EmptyArgs) = do+ liftIO $ do+ UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals)+ S.hFlush S.stdout+ pure Nothing++multiplication :: BuiltInFn+multiplication (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (*) v1 v2+multiplication a = throwBadArgs a "number"++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 a = throwBadArgs a "number/list"++substraction :: BuiltInFn+substraction (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (-) v1 v2+substraction a = throwBadArgs a "number"++division :: BuiltInFn+division (NumberValue _: NumberValue (NumberInt 0) : []) = throwErr $ CustomRTE "Divison by zero!"+division (NumberValue _: NumberValue (NumberFractional 0.0) : []) = throwErr $ CustomRTE "Divison by zero!"+division (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFractionalFn (/) v1 v2+division a = throwBadArgs a "number"++comparison :: (Value -> Value -> Bool) -> BuiltInFn+comparison fn (v1: v2 : []) = pure $ Just $ BoolValue (fn v1 v2)+comparison _ a = throwBadArgs a "values"++boolean :: (Bool -> Bool -> Bool) -> BuiltInFn+boolean fn (BoolValue v1 : BoolValue v2 : []) = pure $ Just $ BoolValue (fn v1 v2)+boolean _ a = throwBadArgs a "bools"++not' :: BuiltInFnWithDoc '[ '("bool", Bool)]+not' ((coerce -> v1) :> _) = pure $ Just $ BoolValue (not v1)++contains :: BuiltInFnWithDoc '[ '("list", Vector Value), '("item", Value)]+contains ((coerce -> v1) :> (coerce -> v2) :> _) = pure $ Just $ BoolValue $ V.foldl' fn False v1+ where+ fn :: Bool -> Value -> Bool+ fn True _ = True+ fn False v = v2 == v++haskey :: BuiltInFnWithDoc '[ '("dictionary", M.Map Text Value), '("key", Text)]+haskey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> _) = pure $ Just $ BoolValue $ M.member key map'++arrayTake :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]+arrayTake ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.take c v1)++arrayDrop :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]+arrayDrop ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.drop c v1)++builtInArrayInsertLeft :: BuiltInFnWithDoc ['("item", Value), '("initial_list", Vector Value)]+builtInArrayInsertLeft ((coerce -> c) :> (coerce -> v1) :> _) = pure $ 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)++builtInWriteFile :: BuiltInFnWithDoc '[ '("filename", FilePath), '("data", BytesOrText)]+builtInWriteFile ((coerce -> filepath) :> (coerce -> bot) :> EmptyArgs) = liftIO $ case bot of+ BTBytes bin -> do+ BS.writeFile filepath bin+ pure Nothing+ BTText dat -> do+ T.writeFile filepath dat+ pure Nothing++builtInReadFile :: BuiltInFnWithDoc '[ '("filename", FilePath)]+builtInReadFile ((coerce -> filepath) :> _) = liftIO $ do+ c <- BS.readFile filepath+ pure $ Just $ BytesValue c++builtInReadTextFile :: BuiltInFnWithDoc '[ '("filename", FilePath)]+builtInReadTextFile ((coerce -> filepath) :> _) = do+ c <- liftIO $ T.readFile filepath+ pure $ Just $ StringValue c++builtInHead :: BuiltInFnWithDoc '[ '("source_list", Vector Value)]+builtInHead ((coerce -> v1) :> _) = case V.uncons v1 of+ Just (x, _) -> pure $ Just x+ Nothing -> throwErr $ CustomRTE "Empty list found for 'head' call"++builtInTry :: BuiltInFnWithDoc '[ '("evaluation", Value), '("alternate", Maybe Value)]+builtInTry ((coerce -> evaluation) :> (coerce -> malternate) :> _) = case (evaluation, malternate) of+ (ErrorValue _, Just a) -> pure $ Just a+ (e@(ErrorValue _), Nothing) -> pure $ Just e+ (v, _) -> pure $ Just v++builtInTimestamp :: BuiltInFnWithDoc '[]+builtInTimestamp _ = do+ st <- liftIO $ truncateSystemTimeLeapSecond <$> getSystemTime+ pure $ Just $ NumberValue $ NumberInt $ ((fromIntegral $ systemSeconds st) * 1e9) + (fromIntegral $ systemNanoseconds st)++builtInJSONSerialize :: BuiltInFnWithDoc '[ '("value", Value)]+builtInJSONSerialize ((coerce -> (v :: Value)) :> _) =+ (Just . BytesValue . BSL.toStrict . A.encode) <$> toAesonVal v++builtInInspect :: BuiltInFnWithDoc '[ '("value", Value)]+builtInInspect ((coerce -> (v :: Value)) :> _) = do+ vText <- (decodeUtf8 . BSL.toStrict . A.encode) <$> toAesonVal v+ liftIO $ do+ T.putStr vText+ S.hFlush S.stdout+ pure Nothing++builtInJSONParse :: BuiltInFnWithDoc '[ '("value", Value)]+builtInJSONParse v = let+ bytes = case v of+ ((coerce -> (StringValue b)) :> _) -> encodeUtf8 b+ ((coerce -> (BytesValue b)) :> _) -> b+ ((coerce -> (a :: Value)) :> _) -> throwErr $ BadArguments ("String/Bytes", T.pack $ show a)+ in case A.eitherDecodeStrict bytes of+ Right val -> pure $ Just $ fromAesonVal val+ Left err -> pure $ Just $ ErrorValue ("JSON decoding failed with error:" <> (T.pack err))++builtInDecodeUTF8Bytes :: BuiltInFnWithDoc '[ '("bytes", BS.ByteString)]+builtInDecodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ StringValue $ decodeUtf8 b++builtInEncodeUTF8Bytes :: BuiltInFnWithDoc '[ '("string", Text)]+builtInEncodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ BytesValue $ encodeUtf8 b++builtInDebug :: BuiltInFnWithDoc '[]+builtInDebug _ = do+ SM.modify (\is -> is { isRunMode = DebugMode, isStepMode = SingleStep })+ pure Nothing++fromAesonVal :: A.Value -> Value+fromAesonVal (A.String s) = StringValue s+fromAesonVal (A.Number s) = NumberValue $ if S.isInteger s then NumberInt (round s) else NumberFractional (realToFrac s)+fromAesonVal (A.Bool b) = BoolValue b+fromAesonVal (A.Array b) = ArrayValue (fromAesonVal <$> b)+fromAesonVal (A.Object b) = ObjectValue (M.fromList $ HM.toList $ fromAesonVal <$> b)+fromAesonVal A.Null = Void++toAesonVal :: Value -> InterpretM A.Value+toAesonVal Void = pure A.Null+toAesonVal (StringValue s) = pure $ A.String s+toAesonVal (NumberValue (NumberInt n)) = pure $ A.Number $ fromIntegral n+toAesonVal (NumberValue (NumberFractional n)) = pure $ A.Number $ realToFrac n+toAesonVal (BoolValue b) = pure $ A.Bool b+toAesonVal (ArrayValue b) = do+ vs <- V.mapM (\x -> toAesonVal x) b+ pure $ A.Array vs+toAesonVal (ObjectValue b) = do+ vs <- Prelude.mapM (\(k, x) -> do v <- toAesonVal x; pure (k, v)) $ M.toList b+ pure $ A.Object $ HM.fromList vs+toAesonVal _ = throwErr $ CustomRTE "Unserializable value"++waitMillisec :: BuiltInFnWithDoc '[ '("timeinseconds", Number)]+waitMillisec ((coerce -> number) :> _) = (liftIO $ waitMillisec' number) >> pure Nothing++waitForKey :: BuiltInFnWithDoc '[]+waitForKey _ = do+ inputChan <- isTerminalEventChan <$> get+ (liftIO $ atomically $ readTChan inputChan) >>= \case+ TerminalKey (KeyChar _ _ _ i) -> do+ pure $ Just $ StringValue $ T.singleton i+ _ -> pure $ Just $ StringValue ""++readChannel :: TChan TerminalEvent -> String -> IO Text+readChannel inputChan c = do+ (liftIO $ atomically $ readTChan inputChan) >>= \case+ TerminalKey (KeyCtrl _ _ _ Return) -> pure $ T.reverse $ T.pack c+ TerminalKey (KeyChar _ _ _ i) -> do+ S.putChar i+ S.hFlush S.stdout+ readChannel inputChan (i:c)+ _ -> readChannel inputChan c++builtinInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)]+builtinInputLine ((coerce -> prompt) :> _) = do+ liftIO $ do+ T.putStrLn prompt+ S.hFlush S.stdout+ inputChan <- isTerminalEventChan <$> get+ (Just . StringValue) <$> (liftIO $ readChannel inputChan "")++toStringVal :: Value -> Text+toStringVal = \case+ StringValue t -> t+ NumberValue (NumberInt i) -> pack $ show i+ NumberValue (NumberFractional i) -> pack $ show i+ BoolValue True -> "true"+ BoolValue False -> "false"+ BytesValue b -> "0x" <> encodeHex b+ ArrayValue _ -> "[array]"+ ObjectValue _ -> "[object]"+ ProcedureValue _ -> "(procedure)"+ ThreadRef _ -> "(thread_ref)"+ Channel _ -> "(concurrency_channel)"+ Ref _ -> "(mutable_ref)"+ UnnamedFnValue _ -> "(unnamed_function)"+ Void -> "(void)"+ BuiltIn _ -> "(builtin)"+ s@(ErrorValue _) -> pack $ show s+ SDLValue s -> pack $ show s++valueSize :: BuiltInFnWithDoc '[ '("list_or_map", Value)]+valueSize ((coerce -> v1) :> _) = case v1 of+ ArrayValue v -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ V.length v+ ObjectValue m -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ M.size m+ v -> throwErr (UnexpectedType ("Array or Object", v))
+ src/Interpreter/Lib/SDL.hs view
@@ -0,0 +1,310 @@+module Interpreter.Lib.SDL where++import Control.Monad.IO.Class+import Control.Monad.Loops+import Control.Monad.State.Strict+import qualified Data.ByteString as BS+import System.Process (createPipe)+import Data.Coerce+import Data.IORef+import Data.Int (Int32)+import qualified Data.List as DL+import qualified Data.Map as M+import Data.Maybe+import Data.WAVE+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import Data.Word+import Foreign.C.Types+import SDL hiding (Keycode, Scancode, get)+import qualified SDL+import SDL.Mixer as SDLM++import Interpreter.Common+import Interpreter.Interpreter++makeSinWaveChunk :: Double -> BS.ByteString+makeSinWaveChunk freq = BS.pack $+ fmap (\n ->+ let t = fromIntegral n / 22050 :: Double+ in round $ 127 + (127 * sin (2 * pi * freq * t)))+ [0 :: Int32 .. 22050]++createGraphicsWindow :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)]+createGraphicsWindow ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) =+ initGraphics (Just (w, h)) (fromMaybe False maccelerated)++createGraphicsFullscreen :: BuiltInFnWithDoc '[ '("accelerated", Maybe Bool)]+createGraphicsFullscreen ((coerce -> maccelerated) :>_) =+ initGraphics Nothing (fromMaybe False maccelerated)++initGraphics :: Maybe (Int, Int) -> Bool -> InterpretM (Maybe Value)+initGraphics md acc = do+ let windowName = "S.P.A.D.E Program"+ (renderer, window) <- liftIO $ do+ SDL.initialize [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer]+ SDLM.openAudio SDLM.defaultAudio 256+ window <- case md of+ Just (w, h) -> SDL.createWindow windowName (windowConfig w h)+ Nothing -> SDL.createWindow windowName fullscreenConfig+ renderer <- case acc of+ True -> SDL.createRenderer window (-1) SDL.defaultRenderer+ _ -> SDL.createRenderer window (-1) $ SDL.defaultRenderer { rendererType = SoftwareRenderer }+ pure (renderer, window)+ sdlWindowRefs <- isSDLWindows <$> get+ liftIO $ modifyIORef sdlWindowRefs (\l -> (window : l))+ modify (\x -> x+ { isDefaultWindow = Just window+ , isDefaultRenderer = Just renderer+ , isAccelerated = Just acc+ })+ pure $ Just $ SDLValue $ Renderer renderer++fullscreenConfig :: SDL.WindowConfig+fullscreenConfig = SDL.defaultWindow+ { windowHighDPI = False+ , windowMode = FullscreenDesktop+ }++windowConfig :: Int -> Int -> SDL.WindowConfig+windowConfig w h = SDL.defaultWindow+ { windowHighDPI = False+ , windowInitialSize = (SDL.V2 (fromIntegral w) (fromIntegral h))+ , windowMode = Windowed+ }++setLogicalSize :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]+setLogicalSize ((coerce -> (lx :: CInt)) :> (coerce -> (ly :: CInt)) :> _) =+ isDefaultRenderer <$> get >>= \case+ Just renderer -> do+ SDL.V2 x y <- getWindowSize'+ SDL.rendererScale renderer SDL.$= (SDL.V2 (realToFrac x/realToFrac lx) (realToFrac y/realToFrac ly))+ pure Nothing+ Nothing -> throwErr $ SDLError "Graphics not Initialized"++getDefaultWindow :: InterpretM SDL.Window+getDefaultWindow = isDefaultWindow <$> get >>= \case+ Just x -> pure x+ Nothing -> throwErr $ SDLError "Graphics not Initialized"++getDefaultRenderer :: InterpretM SDL.Renderer+getDefaultRenderer = isDefaultRenderer <$> get >>= \case+ Just x -> pure x+ Nothing -> throwErr $ SDLError "Graphics not Initialized"++draw :: BuiltInFnWithDoc '[]+draw _ = do+ draw'+ pure Nothing++draw' :: InterpretM ()+draw' = getDefaultRenderer >>= SDL.present++drawIfNotAccelerated :: InterpretM ()+drawIfNotAccelerated = (isAccelerated <$> get) >>= \case+ (Just False) -> draw'+ _ -> pure ()++setDrawColor :: BuiltInFnWithDoc ['("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)]+setDrawColor ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> _) = do+ getDefaultRenderer >>= \renderer -> do+ SDL.rendererDrawColor renderer $= V4 r g b 0+ pure Nothing++clear :: BuiltInFnWithDoc '[]+clear _ = do+ getDefaultRenderer >>= SDL.clear+ pure Nothing++drawPoint :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]+drawPoint ((coerce -> x) :> (coerce -> y) :> _) = do+ renderer <- getDefaultRenderer+ SDL.drawPoint renderer (mkPoint x y)+ drawIfNotAccelerated+ pure Nothing++drawPoints :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]+drawPoints ((coerce -> v) :> _) = do+ renderer <- getDefaultRenderer+ SDL.drawPoints renderer v+ drawIfNotAccelerated+ pure Nothing++drawLines :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]+drawLines ((coerce -> v) :> _) = do+ renderer <- getDefaultRenderer+ SDL.drawLines renderer v+ if VS.length v > 0 then do+ let last' = VS.last v+ SDL.drawPoint renderer last'+ SDL.drawPoint renderer last'+ else pure ()+ drawIfNotAccelerated+ pure Nothing++drawLine :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("end_x", CInt), '("end_y", CInt)]+drawLine ((coerce -> x) :> (coerce -> y) :> (coerce -> xEnd) :> (coerce -> yEnd) :>_) = do+ renderer <- getDefaultRenderer+ let endpoint = mkPoint xEnd yEnd+ SDL.drawLine renderer (mkPoint x y) endpoint+ SDL.drawPoint renderer endpoint+ SDL.drawPoint renderer endpoint+ -- Due to some bug in SDL, without these extra call+ -- the next draw item appear to have a stray pixel with the same color+ -- that was used to draw this one.+ drawIfNotAccelerated+ pure Nothing++drawBox :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("width", CInt), '("height", CInt), '("fill", Maybe Bool)]+drawBox ((coerce -> x) :> (coerce -> y) :> (coerce -> width) :> (coerce -> height) :> (coerce -> fill) :> _) = do+ renderer <- getDefaultRenderer+ let+ f = case fill of+ Just b -> b+ Nothing -> False+ if f+ then SDL.fillRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)+ else SDL.drawRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)+ drawIfNotAccelerated+ pure Nothing++drawCircle :: BuiltInFnWithDoc ['("center_x", Double), '("center_y", Double), '("radius", Double)]+drawCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> _) = do+ renderer <- getDefaultRenderer+ let fullCircle = 2.0 * pi+ let segments = 50+ let (oneSegment :: Double) = fullCircle/segments+ let points = VS.fromList $ (\a -> mkPoint (round $ x + cos (oneSegment * a) * radius) (round $ y + sin (oneSegment * a) * radius)) <$> [0..segments]+ SDL.drawLines renderer points+ let last' = VS.last points+ SDL.drawPoint renderer last'+ SDL.drawPoint renderer last'+ drawIfNotAccelerated+ pure Nothing++waitForSDLKey :: BuiltInFnWithDoc '[]+waitForSDLKey _ = do+ void $ iterateWhile id $ do+ events <- pollEvents+ pure $ ((length $ filter filterEvent events) == 0)+ pure Nothing+ where+ filterEvent :: Event -> Bool+ filterEvent event =+ case eventPayload event of+ KeyboardEvent keyboardEvent ->+ (keyboardEventKeyMotion keyboardEvent == Pressed)+ _ -> False++getWindowSize' :: InterpretM (SDL.V2 CInt)+getWindowSize' = do+ window <- getDefaultWindow+ liftIO $ SDL.get (windowSize window)++getWindowSize :: BuiltInFnWithDoc '[]+getWindowSize _ = do+ (SDL.V2 x y) <- getWindowSize'+ pure $ Just $ ObjectValue $ M.fromList [("width", NumberValue $ NumberInt $ fromIntegral x), ("height", NumberValue $ NumberInt $ fromIntegral y)]++getKeyboardState :: BuiltInFnWithDoc '[]+getKeyboardState _ = do+ SDL.pumpEvents+ fn <- SDL.getKeyboardState+ pure $ Just $ SDLValue $ KeyboardState $ SDLKeyboardStateCallback fn++wasKeyDownIn :: BuiltInFnWithDoc '[ '("keyboard_state", SDLKeyboardStateCallback), '("key", SDL.Scancode) ]+wasKeyDownIn ((coerce -> (SDLKeyboardStateCallback cb)) :> (coerce -> scancode ) :> _) =+ pure $ Just $ BoolValue $ cb scancode++getKeys :: BuiltInFnWithDoc '[]+getKeys _ = do+ events <- pollEvents+ pure $ Just $ ArrayValue $ DL.foldl' convertEvent V.empty events+ where+ convertEvent :: V.Vector Value -> Event -> V.Vector Value+ convertEvent inp event =+ case eventPayload event of+ KeyboardEvent keyboardEvent ->+ V.cons (SDLValue $ Keycode ((keysymKeycode (keyboardEventKeysym keyboardEvent)))) inp+ _ -> inp++builtInSetSampleVolume :: BuiltInFnWithDoc '[ '("channel", Channel), '("volume", Int)]+builtInSetSampleVolume ((coerce -> (channel :: Channel)) :> (coerce -> volume) :> _) = do+ SDLM.setVolume volume channel+ pure Nothing++builtInSetSampleLRVolume :: BuiltInFnWithDoc '[ '("sample", Channel), '("volume_left", Int), '("volume_right", Int)]+builtInSetSampleLRVolume ((coerce -> (channel :: Channel)) :> (coerce -> volumel) :> (coerce -> volumer) :> _) = do+ void $ SDLM.effectPan channel volumel volumer+ pure Nothing++builtInPlaySoundSample :: BuiltInFnWithDoc '[ '("sample", Sample), '("channel", Int)]+builtInPlaySoundSample ((coerce -> sample) :> (coerce -> (channel :: Int)) :> _) = do+ void $ SDLM.playOn (fromIntegral channel) SDLM.Forever sample+ pure Nothing++makeSound :: (Int, [WAVESample]) -> InterpretM Value+makeSound (sampleCount, samplesRaw) = do+ (rEnd, wEnd) <- liftIO createPipe+ let waveData = WAVE (WAVEHeader 1 44100 16 $ Just sampleCount) [samplesRaw]+ waveEncodedData <- liftIO $ do+ hPutWAVE wEnd waveData+ BS.hGetContents rEnd+ chunk <- liftIO $ SDLM.decode waveEncodedData+ pure $ SDLValue $ SoundSample chunk++builtInMakeTone :: BuiltInFnWithDoc '[ '("freq", Double) ]+builtInMakeTone ((coerce -> freq) :> _) = do+ let samplesInOneCycle = 44100 / freq+ let multiplier = (2 * pi)/samplesInOneCycle+ let samplesRaw = [doubleToSample $ sin (realToFrac x * multiplier) | x <- [0 .. (round samplesInOneCycle - 1)]]+ Just <$> makeSound (round samplesInOneCycle, samplesRaw)++builtInMakeSoundSample :: BuiltInFnWithDoc '[ '("samplecount", Int), '("callback", Callback)]+builtInMakeSoundSample ((coerce -> sampleCount) :> (coerce -> (cb :: Callback)) :> _) = do+ samplesRaw <- getSamples sampleCount+ Just <$> makeSound (sampleCount , samplesRaw)+ where+ getSamples :: Int -> InterpretM [WAVESample]+ getSamples sc = mapM (\x -> mapFn x) [1..(fromIntegral sc)]++ mapFn :: Integer -> InterpretM WAVESample+ mapFn si = (doubleToSample . (fromValue @Double) . fromMaybe (throwErr MissingProcedureReturn)) <$>+ evaluateCallback cb [NumberValue $ NumberInt si]++builtInMakeSoundSampleFromFile :: BuiltInFnWithDoc '[ '("filepath", FilePath)]+builtInMakeSoundSampleFromFile ((coerce -> filePath) :> _) = do+ chunk <- liftIO $ SDLM.load filePath+ pure $ Just $ SDLValue $ SoundSample chunk++cleanupSDL :: InterpretM ()+cleanupSDL = do+ sdlWindowRefs <- isSDLWindows <$> get+ windows <- liftIO $ readIORef sdlWindowRefs+ mapM_ (liftIO . SDL.destroyWindow) windows+ modify (\x -> x { isDefaultRenderer = Nothing })+ modify (\x -> x { isDefaultWindow = Nothing })+ SDLM.closeAudio+ SDL.quit++keycodes :: Value+keycodes = ObjectValue $ M.fromList+ [ ("up", SDLValue $ Keycode KeycodeUp)+ , ("down", SDLValue $ Keycode KeycodeDown)+ , ("left", SDLValue $ Keycode KeycodeLeft)+ , ("right", SDLValue $ Keycode KeycodeRight)+ , ("a", SDLValue $ Keycode KeycodeA)+ , ("b", SDLValue $ Keycode KeycodeB)+ , ("c", SDLValue $ Keycode KeycodeC)+ , ("q", SDLValue $ Keycode KeycodeQ)+ , ("s", SDLValue $ Keycode KeycodeS)+ ]++scancodes :: Value+scancodes = ObjectValue $ M.fromList+ [ ("up", SDLValue $ Scancode ScancodeUp)+ , ("down", SDLValue $ Scancode ScancodeDown)+ , ("left", SDLValue $ Scancode ScancodeLeft)+ , ("right", SDLValue $ Scancode ScancodeRight)+ , ("q", SDLValue $ Scancode ScancodeQ)+ ]
+ src/Parser.hs view
@@ -0,0 +1,8 @@+module Parser+ ( module Parser.Parser+ , module Parser.Lib+ ) where++import Parser.Lib+import Parser.Parser+
+ src/Parser/Lib.hs view
@@ -0,0 +1,101 @@+module Parser.Lib where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Data.Text as T++import Common+import Parser.Parser++runParserEither :: forall s a m. (Show s, HaveLocation s, HasEmpty s, MonadIO m) => ParserM m s a -> s -> m (Either (ParseErrorWithParsed a) a)+runParserEither (ParserM _ fn) s = do+ (r, rst) <- fn s+ case r of+ Right res ->+ if isEmpty rst then pure $ Right res else pure $ Left $ ParseErrorWithParsed (Just res) (getLocation rst) (FatalError IncompleteParse)+ Left err -> pure $ Left $ ParseErrorWithParsed Nothing (getLocation rst) err++runParser :: forall a s m. (Show s, HaveLocation s, HasEmpty s, MonadIO m) => ParserM m s a -> s -> m (Maybe a)+runParser p s = runParserEither p s >>= \case+ Right a -> pure $ Just a+ Left _ -> pure Nothing++incLine :: Int -> Parser ()+incLine lc = ParserM "" $ \s -> pure (Right (), s { twLocation = moveLines (twLocation s) lc })++lookAhead :: Monad m => ParserM m s a -> ParserM m s (Maybe a)+lookAhead (ParserM name fn) = ParserM ("lookahead for (" <> name <> ")") $ \s ->+ fn s >>= \case+ (Right a, _) -> pure (Right $ Just a, s)+ (_, _) -> pure (Right Nothing, s)++eof :: (HasEof s, Monad m) => ParserM m s ()+eof = ParserM "EOF" $ \s -> case isEof s of+ True -> pure (Right (), s)+ False -> pure (Left CantHandle, s)++noteof :: (HasEof s, Monad m) => ParserM m s ()+noteof = ParserM "NOT_EOF" $ \s -> case isEof s of+ True -> pure (Left CantHandle, s)+ False -> pure (Right (), s)++pAny :: (Char -> Bool) -> Parser Char+pAny fn = ParserM "" (\t ->+ pure $ case T.uncons $ twText t of+ Just (h, rst) -> if (fn h)+ then (Right h, t { twText = rst, twLocation = moveCols (twLocation t) 1 })+ else (Left CantHandle, t)+ Nothing -> (Left CantHandle, t)+ )++pChar :: Char -> Parser Char+pChar c = pAny (== c)++pText :: Text -> Parser Text+pText l = ParserM l (\t ->+ pure $ if isPrefixOf l $ twText t+ then let tLen = T.length l+ in (Right l, t { twText = T.drop tLen $ twText t, twLocation = moveCols (twLocation t) tLen})+ else (Left CantHandle, t))++parseAndReturn :: Text -> a -> Parser a+parseAndReturn t a = do+ void $ pText t+ pure a++testParser :: Parser [Char]+testParser = do+ a <- pChar 'a'+ b <- pChar 'b'+ pure [a, b]++cantHandle :: Monad m => ParserM m s a+cantHandle = ParserM "" (\s -> pure (Left CantHandle, s))++nameParser :: Text -> ParserM m s a -> ParserM m s a+nameParser name (ParserM _ f) = ParserM name f++class HasInnerParseable a where+ type InnerToken a+ assemble :: InnerToken a -> Location -> Int -> a++class HasParser a where+ parser :: Parser a++instance HasParser a => HasParser [a] where+ parser = many parser++instance {-# OVERLAPPABLE #-} (HasInnerParseable a, ToSource (InnerToken a), HasParser (InnerToken a)) => HasParser a where+ parser = do+ lc <- getParserLocation+ tr <- parser @(InnerToken a)+ let tLength = (T.length $ toSource tr)+ incOffset tLength+ pure $ assemble tr lc (lcOffset lc + tLength - 1)+ where+ incOffset :: Int -> Parser ()+ incOffset size = ParserM "" $ \s -> let+ location = twLocation s+ currentOffset = lcOffset location+ in pure (Right (), s { twLocation = location { lcOffset = currentOffset + size }} )
+ src/Parser/Parser.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE InstanceSigs #-}+module Parser.Parser where++import Common++import Control.Applicative+import Control.Monad.IO.Class+import Data.String (IsString(..))+import Data.Text as T++data ParseErrorWithParsed a = ParseErrorWithParsed+ { parialResult :: Maybe a+ , errorAt :: Location+ , parseError :: ParseError+ } deriving (Eq, Show)++instance HReadable (ParseErrorWithParsed a) where+ hReadable ParseErrorWithParsed {..} = "Incomplete parse: Error at: " <> (hReadable errorAt) <> " Error:" <> (hReadable parseError)++data FatalParseError+ = IncompleteParse+ | CustomError Text+ deriving (Show, Eq)++instance HReadable FatalParseError where+ hReadable = \case+ IncompleteParse -> "Input does not match any known pattern at location"+ CustomError msg -> "Fatal parse error:" <> msg++moveLines :: Location -> Int -> Location+moveLines Location {..} lc = let+ lcNewLine = lcLine + lc+ in Location {lcLine = lcNewLine, lcColumn = 0, ..}++moveCols :: Location -> Int -> Location+moveCols Location {..} lc = let+ lcNewColumn = lcColumn + lc+ in Location {lcColumn = lcNewColumn, ..}++data ParseError+ = CantHandle+ | Empty+ | FatalErrorWithLocation Location FatalParseError+ | FatalError FatalParseError+ deriving (Show, Eq)++instance HReadable ParseError where+ hReadable = \case+ CantHandle -> "Parser can't handle this input"+ Empty -> "The input was empty"+ FatalErrorWithLocation l fp -> "Fatal parse error:" <> (hReadable fp) <> " at:" <> (hReadable l)+ FatalError fp -> "Fatal parse error:" <> (hReadable fp)++class HaveLocation a where+ getLocation :: a -> Location++getParserLocation :: (Monad m, HaveLocation s) => ParserM m s Location+getParserLocation = ParserM "" $ \s -> pure (Right $ getLocation s, s)++data ParserM m s a = ParserM Text (s -> m (Either ParseError a, s))++data TextWithOffset = TextWithOffset+ { twText :: Text+ , twLocation :: Location+ } deriving (Eq, Show)++class HasEof a where+ isEof :: a -> Bool++instance ToSource TextWithOffset where+ toSource = twText++instance HasEof TextWithOffset where+ isEof (TextWithOffset "" _) = True+ isEof _ = False++instance HasEmpty TextWithOffset where+ isEmpty t = twText t == ""++toTextWithOffset :: Text -> TextWithOffset+toTextWithOffset t = TextWithOffset t emptyLocation++instance HaveLocation TextWithOffset where+ getLocation = twLocation++instance IsString s => IsString TextWithOffset where+ fromString s = toTextWithOffset $ T.pack s++class HasLogIndent a where+ incIndent :: a -> a+ decIndent :: a -> a+ logInfo :: MonadIO m => Text -> a -> m ()++instance Show a => HasLogIndent a where+ incIndent a = a+ decIndent a = a+ logInfo _ _ = pure ()++type Parser a = ParserM IO TextWithOffset a++type ParserC m s = (MonadIO m, HasLogIndent s, ToSource s)++instance ParserC m s => Functor (ParserM m s) where+ fmap f (ParserM name a) = ParserM name (\s -> (a $ incIndent s) >>= \case+ (Right a', s') -> pure (Right $ f a', s')+ (Left e, _) -> pure (Left e, s))++instance ParserC m s => Applicative (ParserM m s) where+ pure a = ParserM "pure" (\s -> pure (Right a, s))+ (ParserM name1 f1) <*> (ParserM name2 f2) = ParserM (name2 <> " after " <> name1)+ (\s -> (do logInfo name1 s; f1 $ incIndent s) >>= \case+ (Right fn, rst) -> (f2 $ decIndent rst) >>= \case+ (mf, rst1) -> pure (fn <$> mf, decIndent rst1)+ (Left err, s') -> pure (Left err, decIndent s')+ )++instance ParserC m s => Monad (ParserM m s) where+ return = pure+ (ParserM name1 f1) >>= f =+ ParserM name1 (\s -> (do logInfo name1 s; f1 $ incIndent s) >>= \case+ (Right a1, rst) ->+ let+ (ParserM name2 f2) = f a1+ rst' = decIndent rst+ in do+ logInfo ("success " <> name1) rst'+ logInfo ("parsing " <> name2) rst'+ f2 rst'+ (Left err, s') -> do+ logInfo ("failed " <> name1) s'+ pure (Left err, s'))++instance ParserC m s => Alternative (ParserM m s) where+ (ParserM name1 f1) <|> (ParserM name2 f2) = ParserM ("(" <> name1 <> ")" <> " or (" <> name2 <> ")") (\s -> (do logInfo name1 s; f1 s)>>= \case+ (Left e@(FatalError _), s') -> pure (Left e, s')+ (Left e@(FatalErrorWithLocation _ _), s') -> pure (Left e, s')+ (Left _, _) -> f2 s+ a -> pure a )+ empty = ParserM "empty" (\s -> pure (Left Empty, s))+ many p@(ParserM name _) = let (ParserM _ fn) = ((some p) <|> (pure [])) in ParserM ("many of " <> name) fn+ some (ParserM name fn) = ParserM ("some of " <> name) (\s -> collect ([], s) >>= \case+ (Right [], _) -> pure (Left CantHandle, s)+ (Right (r@(_:_)), rst) -> pure (Right (Prelude.reverse r), rst)+ (Left err, rst) -> pure (Left err, rst))+ where+ collect (i, s) = fn s >>= \case+ (Right a, rst) -> collect ((a:i), rst)+ (Left e@(FatalError _), s') -> pure (Left e, s')+ (Left e@(FatalErrorWithLocation _ _), s') -> pure (Left e, s')+ (Left _, _) -> pure (Right i, s)++instance (ParserC m s, HaveLocation s) => MonadFail (ParserM m s) where+ fail err = ParserM "fail" (\s -> pure (Left (FatalErrorWithLocation (getLocation s) $ CustomError $ pack err), s))++instance (ParserC m s, MonadIO m) => MonadIO (ParserM m s) where+ liftIO io = ParserM "liftIO" (\s -> do+ r <- liftIO io+ pure (Right r, s))
+ src/Test.hs view
@@ -0,0 +1,24 @@+module Test where++import Compiler.Parser+import Control.Applicative+import Data.Text as T+import Data.Text.IO as T+import Parser++import Compiler.AST.Parser.Common+import Compiler.AST.Program++testDummy :: IO ()+testDummy = do+ src <- T.readFile "/tmp/input.txt"+ tokens <- tokenize src+ --T.putStrLn $ T.pack $ show tokens+ x <- runParserEither (do+ st <- optional testParser_+ pure st+ ) $ mkAstParserState tokens+ T.putStrLn $ T.pack $ show x+ pure ()+ where+ testParser_ = astParser @Program
+ src/Test/Common.hs view
@@ -0,0 +1,23 @@+module Test.Common+ ( module Test.Common+ , module Hedgehog+ , module Hedgehog.Gen+ , module Hedgehog.Range+ , module Test.Hspec+ ) where++import Hedgehog (Gen, Property, forAll, liftTest, property, (===))+import Hedgehog.Gen (bool, choice, element, enum, int, list, lower, maybe,+ realFrac_, recursive, text, upper)+import Hedgehog.Range (linear, linearFrac)+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Hedgehog++class HasGen a where+ getGen :: Gen a++instance HasGen a => HasGen [a] where+ getGen = list (linear 0 5) getGen++instance HasGen a => HasGen (Maybe a) where+ getGen = Hedgehog.Gen.maybe getGen
+ src/UI/Chars.hs view
@@ -0,0 +1,21 @@+module UI.Chars where++import Data.Char++verticalLine :: Char+verticalLine = chr 0x2502++horizontalLine :: Char+horizontalLine = chr 0x2500++cornerLT :: Char+cornerLT = chr 0x250c++cornerRT :: Char+cornerRT = chr 0x2510++cornerRB :: Char+cornerRB = chr 0x2518++cornerLB :: Char+cornerLB = chr 0x2514
+ src/UI/Terminal/IO.hs view
@@ -0,0 +1,23 @@+module UI.Terminal.IO+ ( module UI.Terminal.IO+ , S.stdin+ , S.stdout+ , S.BufferMode (..)+ ) where++import Data.Text (Text)+import qualified System.IO as S++class Monad m => HasTerminal m where+ setCursorPosition :: Int -> Int -> m ()+ hideCursor :: m ()+ showCursor :: m ()+ putText :: Text -> m ()+ putTextFlush :: Text -> m ()+ hFlush :: m ()+ hSetEcho :: S.Handle -> Bool -> m ()+ hSetBuffering :: S.Handle -> S.BufferMode -> m ()+ hGetChar :: m Char+ hWaitForInput :: m Bool+ clearscreen :: m ()+ clearline :: m ()
+ src/UI/Widgets.hs view
@@ -0,0 +1,14 @@+module UI.Widgets+ ( module UI.Widgets.Common+ , module UI.Widgets.Editor+ , module UI.Widgets.BorderBox+ , module UI.Widgets.MenuContainer+ ) where++import Control.Monad+import System.IO++import UI.Widgets.BorderBox+import UI.Widgets.Common+import UI.Widgets.Editor+import UI.Widgets.MenuContainer
+ src/UI/Widgets/AutoComplete.hs view
@@ -0,0 +1,99 @@+module UI.Widgets.AutoComplete where++import Data.Text as T+import Data.Typeable (Proxy, eqT, (:~:)(..))+import System.Console.ANSI (Color(..))+import Text.Printf++import Common+import Highlighter.Highlighter+import UI.Widgets.Common++data AutoCompleteWidget = AutoCompleteWidget+ { acwContent :: [(Text, Text)]+ , acwSelected :: Int+ , acwPos :: ScreenPos+ , acwVisibility :: Bool+ }++instance Container AutoCompleteWidget [(Text, Text)] where+ setContent ref t = do+ modifyWRef ref (\tcw -> tcw { acwContent = t, acwSelected = 0 })+ getContent ref =+ acwContent <$> readWRef ref++instance Selectable AutoCompleteWidget where+ getSelection ref = do+ w <- readWRef ref+ case safeIndex (acwContent w) (acwSelected w) of+ Just (x, _) -> pure x+ Nothing -> pure ""++instance KeyInput AutoCompleteWidget where+ getCursorInfo _ = pure Nothing+ handleInput ref ev =+ case ev of+ KeyCtrl _ _ _ ArrowUp -> do+ w <- readWRef ref+ let selected = acwSelected w+ if (selected > 0)+ then modifyWRef ref (\a -> a { acwSelected = selected - 1 } )+ else pure ()+ KeyCtrl _ _ _ ArrowDown -> do+ w <- readWRef ref+ let selected = acwSelected w+ if (selected < (Prelude.length (acwContent w) - 1))+ then modifyWRef ref (\a -> a { acwSelected = selected + 1 } )+ else pure ()+ _ -> pure ()++instance Moveable AutoCompleteWidget where+ move r p = modifyWRef r (\w -> w { acwPos = p })+ getPos r = acwPos <$> readWRef r+ getDim r = do+ w <- readWRef r+ let+ c = acwContent w+ contentLength = Prelude.length $ acwContent w+ maxContentLength = case c of+ [] -> 0+ cnt@(_:_) -> Prelude.maximum $ (T.length . snd) <$> cnt+ pure $ Dimensions (maxContentLength+2) (contentLength+2)+ resize _ _ = pure ()++instance Widget AutoCompleteWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (SelectableCap _) = Just Dict+ hasCapability (KeyInputCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability (ContainerCap _ (_ :: Proxy cnt)) = case eqT @cnt @([(Text, Text)]) of+ Just Refl -> Just Dict+ Nothing -> Nothing++instance Drawable AutoCompleteWidget where+ setVisibility ref v = modifyWRef ref (\c -> c { acwVisibility = v })+ getVisibility ref = acwVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ if (acwVisibility w)+ then do+ case acwContent w of+ (_:_) -> do+ let contentLen = Prelude.length $ acwContent w+ let maxWidth = Prelude.maximum (0 : ((T.length . snd) <$> acwContent w))+ drawBorderBox (acwPos w) (Dimensions (maxWidth + 2) (2 + contentLen))+ mapM_ (putOneItem w (acwPos w) maxWidth) $ Prelude.zip [0..] (acwContent w)+ _ -> pure ()+ else pure ()+ where+ putOneItem w sp mw (offset, item) = do+ wSetCursor+ $ moveDown (offset + 1) $ moveRight 1 sp+ let stx = "%-" <> (show mw) <>"s"+ if offset == (acwSelected w)+ then csPutText (colorTextFg Blue (T.pack $ printf stx (snd item)))+ else csPutText (colorTextFg White (T.pack $ printf stx (snd item)))++autoComplete+ :: WidgetM m (WRef AutoCompleteWidget)+autoComplete = newWRef $ AutoCompleteWidget [] 0 origin False
+ src/UI/Widgets/BorderBox.hs view
@@ -0,0 +1,56 @@+module UI.Widgets.BorderBox where++import UI.Widgets.Common as C+import Common++data BorderBoxWidget = BorderBoxWidget+ { bbwDim :: Dimensions+ , bbwContent :: SomeWidgetRef+ , bbwPos :: ScreenPos+ , bbwVisible :: Bool+ }++instance Container BorderBoxWidget SomeWidgetRef where+ setContent ref c =+ modifyWRef ref (\bbw -> bbw { bbwContent = c })+ getContent ref = bbwContent <$> readWRef ref++instance Moveable BorderBoxWidget where+ getPos ref = bbwPos <$> readWRef ref+ move ref sp =+ modifyWRef ref (\bbw -> bbw { bbwPos = sp })+ getDim ref =+ bbwDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\low -> low { bbwDim = cb $ bbwDim low })++instance Widget BorderBoxWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability _ = Nothing++instance Drawable BorderBoxWidget where+ setVisibility ref v = modifyWRef ref (\b -> b { bbwVisible = v })+ getVisibility ref = bbwVisible <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ drawBorderBox (bbwPos w) (bbwDim w)+ case bbwContent w of+ SomeWidgetRef a -> do+ withCapability (DrawableCap a) $ do+ withCapability (MoveableCap a) $ do+ move a (moveDown 1 $ moveRight 1 $ bbwPos w)+ draw a++borderBox+ :: forall m. ScreenPos+ -> Dimensions+ -> SomeWidgetRef+ -> WidgetM m (WRef BorderBoxWidget)+borderBox pos dim child = do+ newWRef $+ BorderBoxWidget+ { bbwDim = dim+ , bbwContent = child+ , bbwPos = pos+ , bbwVisible = True+ }
+ src/UI/Widgets/Common.hs view
@@ -0,0 +1,455 @@+module UI.Widgets.Common+ ( module UI.Widgets.Common+ , module UI.Terminal.IO+ , module Control.Monad+ , module Data.Text+ , module Control.Monad.IO.Class+ , module Control.Monad.State.Strict+ , module Data.Constraint+ , module GHC.Stack+ ) where++import Common+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Loops (iterateWhile)+import Data.Constraint+import Data.Kind (Type)+import qualified Data.List as DL+import Data.Map.Strict as M hiding (keys)+import Data.Maybe+import Data.Text as T+import Data.Text hiding (lines)+import qualified Data.Text as C+import Data.Text.IO as T+import Data.Typeable (Proxy(..), Typeable, cast, typeRep)+import Data.Vector.Mutable (IOVector)+import qualified Data.Vector.Mutable as MV+import GHC.Stack+import qualified Graphics.Vty as VTY+import System.Random+import UI.Chars+import UI.Terminal.IO++import Control.Monad+import Control.Monad.State.Strict+import qualified System.Console.ANSI as A+import qualified System.IO as S++data WidgetState = WidgetState+ { wsWidgets :: Map Int SomeWidget+ , wsCursorWidget :: Maybe SomeKeyInputWidget -- Widget that authoritativly decide the status/location of cursor. Does not decide what widgets receive keyboard input+ , wsScreenState :: ScreenState+ , wsCursorVisible :: Bool+ , wsScreenStateBack :: ScreenState+ }++data ScreenState = ScreenState+ { ssLines :: IOVector [StyledText]+ , ssCursorPos :: ScreenPos+ , ssColumns :: Int+ , ssCursorOverflow :: Bool+ }++setCursorVisibility :: WidgetC m => Bool -> m ()+setCursorVisibility b = modify (\ws -> ws { wsCursorVisible = b })++emptyScreenState :: Int -> Int -> IO ScreenState+emptyScreenState rows cols = do+ stLines <- MV.generate rows (\_ -> [Plain (T.replicate cols " ")])+ pure (ScreenState stLines (ScreenPos 0 0) cols True)++emptyWidgetState :: Int -> Int -> IO WidgetState+emptyWidgetState lineCount columns = do+ ss <- emptyScreenState lineCount columns+ ssBack <- emptyScreenState lineCount columns+ pure $ WidgetState mempty Nothing ss True ssBack++type WidgetM m a = MonadIO m => StateT WidgetState m a++runWidgetM' :: MonadIO m => WidgetM m a -> m (a, WidgetState)+runWidgetM' act = do+ ws <- liftIO $ emptyWidgetState 0 0+ flip runStateT ws act++runWidgetM :: MonadIO m => WidgetM m a -> m a+runWidgetM act = fst <$> runWidgetM' act++type WidgetC m =+ ( HasCallStack+ , HasCharScreen m+ , HasRandom m+ , HasLog m+ , HasTerminal m+ , MonadState WidgetState m+ , MonadIO m+ )++getScreenBounds :: WidgetC m => m Dimensions+getScreenBounds = do+ screenState <- wsScreenState <$> get+ let+ screenLines = ssLines screenState+ screenColumns = ssColumns screenState+ pure $ Dimensions screenColumns (MV.length screenLines)++instance MonadIO m => HasRandom (StateT WidgetState m) where+ getRandom = liftIO randomIO++instance MonadIO m => HasCharScreen (StateT WidgetState m) where+ csInitialize (Dimensions cols rows) = do+ -- Initialize the screen memory for the dimensions+ -- and initialize to whitespaces.+ (ss, ssBack) <- liftIO $ do+ ss <- emptyScreenState rows cols+ ssBack <- emptyScreenState rows cols+ pure (ss, ssBack)+ modify (\ws -> ws { wsScreenState = ss, wsScreenStateBack = ssBack })++ csClear = do+ -- Clears the back buffer before starting to write+ -- stuff.+ bb <- wsScreenStateBack <$> get+ liftIO $ MV.set (ssLines bb) [Plain (T.replicate (ssColumns bb) " ")]++ csDraw = do+ -- ^ Compares the stuff that has been written to backbuffer+ -- with the stuff already on frontbuffer, and send the instructions+ -- to draw the changes. Then switch frontbuffer and backbuffers to+ -- prepare for the next draw cycle.+ WidgetState { wsScreenState = (ssLines -> ss), wsScreenStateBack = (ssLines -> ssb) } <- get+ liftIO $ MV.imapM_ (\idx neLine -> do+ oldLine <- MV.read ss idx+ if (oldLine /= neLine)+ then do+ A.setCursorPosition idx 0+ -- mapM_ (\x -> do T.putStr x; S.hFlush stdout; threadDelay 10000;) (stRender <$> neLine)+ mapM_ T.putStr (stRender <$> neLine)+ S.hFlush stdout+ else pure ()+ ) ssb+ wsCursorVisible <$> get >>= \case+ False -> pure ()+ True ->+ (wsCursorWidget <$> get) >>= \case+ Just (SomeKeyInputWidget fref) -> getCursorInfo fref >>= \case+ Just (cl, csst) -> do+ liftIO $ A.setCursorPosition (sY cl) (sX cl)+ putTextFlush $ cursorStyleCode csst+ Nothing -> pure ()+ Nothing -> pure ()+ modify (\ws -> ws { wsScreenStateBack = wsScreenState ws, wsScreenState = wsScreenStateBack ws })++ csPutText t = do+ -- Write stuff to the backbuffer. If the cursor is in an overflow position, then do nothing.+ (ScreenState {ssLines = ssLns, ssCursorOverflow = cursorOverflow, ssCursorPos = ScreenPos cx cy}) <- wsScreenStateBack <$> get+ if cursorOverflow+ then pure ()+ else liftIO $ flip (MV.modify ssLns) cy $ \l -> stInsert l cx t++ csSetCursorPosition x y = do+ -- Sets the cursor position in the backbuffer.+ modify (\ws ->+ let+ screenState = wsScreenStateBack ws+ screenLines = ssLines screenState+ screenColumns = ssColumns screenState+ in if (x >= 0 && x < screenColumns) && (y >= 0 && y < (MV.length screenLines))+ then ws { wsScreenStateBack = screenState { ssCursorOverflow = False, ssCursorPos = ScreenPos x y }}+ else ws { wsScreenStateBack = screenState { ssCursorOverflow = True }})++getTerminalSizeIO :: IO (Maybe (Int, Int))+getTerminalSizeIO = do+ A.getTerminalSize >>= \case+ Just (y, x) -> pure $ Just (x, y)+ Nothing -> pure Nothing++instance MonadIO m => HasTerminal (StateT WidgetState m) where+ setCursorPosition x y = do+ liftIO $ A.setCursorPosition y x+ hFlush+ hideCursor = liftIO A.hideCursor+ showCursor = do+ liftIO A.showCursor+ hFlush+ putText t = liftIO $ do+ T.putStr t+ putTextFlush t = do+ putText t+ hFlush+ hFlush = liftIO $ S.hFlush S.stdout+ hSetEcho h b = liftIO $ S.hSetEcho h b+ hGetChar = liftIO $ S.hGetChar S.stdin+ hSetBuffering h b = liftIO $ S.hSetBuffering h b+ hWaitForInput = liftIO $ S.hWaitForInput stdin 0+ clearscreen = do+ liftIO A.clearScreen+ hFlush+ clearline = liftIO $ A.hClearFromCursorToLineEnd stdout++instance MonadIO m => HasLog (StateT WidgetState m) where+ appendLog a = liftIO (appendLog a)++-- Below, the type parameter `a` is left in case we need to use tagged+-- references, like an IORef.+newtype WRef (a :: Type) = WRef Int+ deriving newtype (Eq, Ord)++strToKeyEvent :: String -> [KeyEvent]+-- gnome-terminal+strToKeyEvent ('\DEL': rst) = (KeyCtrl False False False Backspace):strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'A' : rst) = (KeyCtrl False False False ArrowUp) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'B' : rst) = (KeyCtrl False False False ArrowDown) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'H' : rst) = (KeyCtrl False False False Home) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'F' : rst) = (KeyCtrl False False False End) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'C' : rst) = (KeyCtrl False False False ArrowRight) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : 'D' : rst) = (KeyCtrl False False False ArrowLeft) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '2' : '~': rst) = (KeyCtrl False False False Insert) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '3' : '~': rst) = (KeyCtrl False False False Del) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1' : '5': '~': rst) = (KeyCtrl False False False (Fun 5)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1' : '7': '~': rst) = (KeyCtrl False False False (Fun 6)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '2' : '1': '~': rst) = (KeyCtrl False False False (Fun 10)) : strToKeyEvent rst+strToKeyEvent ('\ESC': 'O' : 'P': rst) = (KeyCtrl False False False (Fun 1)) : strToKeyEvent rst+strToKeyEvent ('\ESC': 'O' : 'Q': rst) = (KeyCtrl False False False (Fun 2)) : strToKeyEvent rst+strToKeyEvent ('\ESC': 'O' : 'R': rst) = (KeyCtrl False False False (Fun 3)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1': '9': ';' : '5' : '~' : rst) = (KeyCtrl True False False (Fun 8)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1': ';' : '2' : 'C' : rst) = (KeyCtrl True False False (ArrowRight)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1': ';' : '2' : 'D' : rst) = (KeyCtrl True False False (ArrowLeft)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1': ';' : '2' : 'B' : rst) = (KeyCtrl True False False (ArrowDown)) : strToKeyEvent rst+strToKeyEvent ('\ESC': '[' : '1': ';' : '2' : 'A' : rst) = (KeyCtrl True False False (ArrowUp)) : strToKeyEvent rst++-- Linux term+strToKeyEvent ('\ESC': '[' : '[' : 'E': rst) = (KeyCtrl False False False (Fun 5)) : strToKeyEvent rst+--+strToKeyEvent ('\ESC': c : rst ) = (KeyChar False False True c) : strToKeyEvent rst+strToKeyEvent ('\ESC' : rst) = (KeyCtrl False False False Esc) : strToKeyEvent rst+strToKeyEvent ('\n': rst) = (KeyCtrl False False False Return) : strToKeyEvent rst+strToKeyEvent str = KeyChar False False False <$> str++initializeVty :: IO VTY.Vty+initializeVty =+ VTY.standardIOConfig >>= VTY.mkVty++shutdownVty :: VTY.Vty -> IO ()+shutdownVty vty = VTY.shutdown vty++readVtyEvent :: VTY.Vty -> IO [TerminalEvent]+readVtyEvent vty = VTY.nextEvent vty >>= \x -> do+ case x of+ VTY.EvResize w h -> pure [TerminalResize w h]+ VTY.EvKey k mods -> pure $ TerminalKey <$> case k of+ VTY.KChar c -> [setModifiers mods $ KeyChar False False False c]+ VTY.KUp -> [setModifiers mods $ KeyCtrl False False False ArrowUp]+ VTY.KDown -> [setModifiers mods $ KeyCtrl False False False ArrowDown]+ VTY.KRight -> [setModifiers mods $ KeyCtrl False False False ArrowRight]+ VTY.KLeft -> [setModifiers mods $ KeyCtrl False False False ArrowLeft]+ VTY.KEsc -> [setModifiers mods $ KeyCtrl False False False Esc]+ VTY.KEnter -> [setModifiers mods $ KeyCtrl False False False Return]+ VTY.KFun 32 -> [setModifiers (VTY.MCtrl : mods) $ KeyCtrl False False False (Fun 8)]+ VTY.KFun n -> [setModifiers mods $ KeyCtrl False False False (Fun n)]+ VTY.KBS -> [setModifiers mods $ KeyCtrl False False False Backspace]+ VTY.KHome -> [setModifiers mods $ KeyCtrl False False False Home]+ VTY.KEnd -> [setModifiers mods $ KeyCtrl False False False End]+ VTY.KDel -> [setModifiers mods $ KeyCtrl False False False Del]+ _ -> []+ _ -> pure []+ where+ setModifiers :: [VTY.Modifier] -> KeyEvent -> KeyEvent+ setModifiers mods key = DL.foldl' foldFn key mods++ foldFn :: KeyEvent -> VTY.Modifier -> KeyEvent+ foldFn (KeyCtrl c _ a v) VTY.MShift = KeyCtrl c True a v+ foldFn (KeyCtrl _ s a v) VTY.MCtrl = KeyCtrl True s a v+ foldFn (KeyCtrl c s _ v) VTY.MMeta = KeyCtrl c s True v+ foldFn (KeyCtrl c s _ v) VTY.MAlt = KeyCtrl c s True v+ foldFn (KeyChar c _ a v) VTY.MShift = KeyChar c True a v+ foldFn (KeyChar _ s a v) VTY.MCtrl = KeyChar True s a v+ foldFn (KeyChar c s _ v) VTY.MMeta = KeyChar c s True v+ foldFn (KeyChar c s _ v) VTY.MAlt = KeyChar c s True v++readKey :: IO [KeyEvent]+readKey = do+ k <- readKey_+ pure $ strToKeyEvent k++readKey_ :: IO String+readKey_ = do+ char <- S.hGetChar S.stdin+ readRest [char]+ where+ readRest :: [Char] -> IO [Char]+ readRest t = S.hWaitForInput stdin 0 >>= \case+ True -> do+ c <- S.hGetChar S.stdin+ readRest (c:t)+ False -> pure $ Prelude.reverse t++uiLoop :: forall m event. (Show event, WidgetC m) => TChan event -> (event -> m Bool) -> m ()+uiLoop es cback = do+ void $ iterateWhile id $ do+ event <- liftIO $ atomically $ readTChan es+ r <- cback event+ pure r++cursorStyleCode :: CursorStyle -> Text+cursorStyleCode Bar = T.pack $ "\ESC[5 q" <> A.showCursorCode+cursorStyleCode Underline = T.pack $ "\ESC[4 q" <> A.showCursorCode+cursorStyleCode Hidden = T.pack A.hideCursorCode++readWRef :: forall a m. (WidgetC m, Widget a) => WRef a -> m a+readWRef (WRef ref) = do+ (fromMaybe (error "not found") . M.lookup ref . wsWidgets) <$> get >>= \case+ SomeWidget w -> case cast w of+ Just a -> pure a+ Nothing -> error "Unexpected type"++modifyWRef :: (WidgetC m, Widget a) => WRef a -> (a -> a) -> m ()+modifyWRef (WRef ref) fn =+ modify $ \s -> s { wsWidgets = M.update (Just . (modifySomeWidget fn)) ref $ wsWidgets s }++modifyWRefM :: (WidgetC m, Widget a) => WRef a -> (a -> m a) -> m ()+modifyWRefM (WRef ref) fn = do+ m <- wsWidgets <$> get+ case M.lookup ref m of+ Just sw -> do+ nSw <- modifySomeWidgetM fn sw+ modify $ \s -> s { wsWidgets = M.update (\_ -> Just nSw) ref $ wsWidgets s }+ Nothing -> pure ()++modifySomeWidget :: Widget a => (a -> a) -> SomeWidget -> SomeWidget+modifySomeWidget fn (SomeWidget w) = case cast w of+ Just a -> (SomeWidget (fn a))+ Nothing -> error "unexpected type"++modifySomeWidgetM :: (Monad m, Widget a) => (a -> m a) -> SomeWidget -> m SomeWidget+modifySomeWidgetM fn (SomeWidget w) = case cast w of+ Just a -> do+ n <- fn a+ pure (SomeWidget n)+ Nothing -> error "unexpected type"++-- Insert the new widget at a random key in the Widget state map+-- and return the key.+newWRef :: (WidgetC m, Widget a) => a -> m (WRef a)+newWRef a = do+ ref <- getRandom+ modify $ \s -> s { wsWidgets = M.insert ref (SomeWidget a) $ wsWidgets s }+ pure (WRef ref)++data CtrlKey+ = Del+ | Esc+ | Insert+ | End+ | Home+ | ArrowLeft+ | ArrowRight+ | ArrowUp+ | ArrowDown+ | Backspace+ | Fun Int+ | Return+ deriving (Show, Ord, Eq)++data KeyEvent+ = KeyChar Bool Bool Bool Char+ | KeyCtrl Bool Bool Bool CtrlKey+ deriving (Show, Eq, Ord)++data TerminalEvent+ = TerminalKey KeyEvent+ | TerminalResize Int Int+ deriving Show++data TerminalException+ = TerminalException Text+ deriving (Show)++instance Exception TerminalException++class HasRandom m where+ getRandom :: Random a => m a++class HasCursor m where+ getCursor :: m CursorInfo++class HasCharScreen m where+ csInitialize :: Dimensions -> m ()+ csClear :: m ()+ csDraw :: m ()+ csPutText :: StyledText -> m ()+ csSetCursorPosition :: Int -> Int -> m ()++class Layout a where+ addWidget :: (WidgetC m, Widget child) => WRef a -> Text -> WRef child -> m ()+ setTextFocus :: WidgetC m => WRef a -> Text -> m ()++class Drawable a where+ draw :: (WidgetC m) => WRef a -> m ()+ setVisibility :: WidgetC m => WRef a -> Bool -> m ()+ getVisibility :: WidgetC m => WRef a -> m Bool++class Moveable a where+ move :: WidgetC m => WRef a -> ScreenPos -> m ()+ getPos :: WidgetC m => WRef a -> m ScreenPos+ getDim :: WidgetC m => WRef a -> m Dimensions+ resize :: WidgetC m => WRef a -> (Dimensions -> Dimensions) -> m ()++class Container a c | a -> c where+ setContent :: WidgetC m => WRef a -> c -> m ()+ getContent :: WidgetC m => WRef a -> m c++class Selectable a where+ getSelection :: WidgetC m => WRef a -> m Text++class (Typeable a, Drawable a) => KeyInput a where+ getCursorInfo :: WidgetC m => WRef a -> m (Maybe CursorInfo)+ handleInput :: WidgetC m => WRef a -> KeyEvent -> m ()++data WidgetCapability a (c :: Constraint) where+ KeyInputCap :: WRef a -> WidgetCapability a (KeyInput a)+ MoveableCap :: WRef a -> WidgetCapability a (Moveable a)+ SelectableCap :: WRef a -> WidgetCapability a (Selectable a)+ DrawableCap :: WRef a -> WidgetCapability a (Drawable a)+ ContainerCap :: Typeable cnt => WRef a -> Proxy cnt -> WidgetCapability a (Container a cnt)++class Typeable a => Widget a where+ hasCapability :: WidgetCapability a c -> Maybe (Dict c)++withCapability :: forall a c m b . (WidgetC m, Widget a, Typeable c) => WidgetCapability a c -> (c => m b) -> m b+withCapability cap fn = case hasCapability cap of+ Just Dict -> fn+ Nothing -> error ("No capability:" <> (show $ typeRep (Proxy @c)))++data SomeWidget where+ SomeWidget :: forall a. Widget a => a -> SomeWidget++data SomeWidgetRef where+ SomeWidgetRef :: forall a. (Typeable a, Widget a) => WRef a -> SomeWidgetRef++data SomeKeyInputWidget where+ SomeKeyInputWidget :: KeyInput a => WRef a -> SomeKeyInputWidget++wSetCursor :: (WidgetC m, HasTerminal m) => ScreenPos -> m ()+wSetCursor ScreenPos {..} = csSetCursorPosition sX sY++wSetCursorRel :: (HasTerminal m, WidgetC m) => ScreenPos -> ScreenPos -> m ScreenPos+wSetCursorRel o rel = do+ let n = moveRight (sX rel) $ moveDown (sY rel) o+ wSetCursor n+ pure n++drawBorderBox :: WidgetC m => ScreenPos -> Dimensions -> m ()+drawBorderBox sp Dimensions {..} = do+ wSetCursor sp+ csPutText $ Plain $ C.concat [C.singleton cornerLT, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRT]+ wSetCursor $ moveDown (diH - 1) sp+ csPutText $ Plain $ C.concat [C.singleton cornerLB, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRB]+ forM_ [1..(diH - 2)] (\r -> do+ wSetCursor $ moveDown r sp+ csPutText $ Plain $ C.concat [C.singleton verticalLine]+ wSetCursor $ moveRight (diW - 1) $ moveDown r sp+ csPutText $ Plain $ C.concat [C.singleton verticalLine]+ )
+ src/UI/Widgets/Editor.hs view
@@ -0,0 +1,571 @@+module UI.Widgets.Editor where++import Control.Monad.Loops (iterateUntilM)+import Data.List as DL hiding (lines)+import Data.Maybe+import Data.Proxy (Proxy(..))+import Data.Text as T+import Prelude hiding (lines)+import System.Console.ANSI (Color(..))+import Text.Printf++import Common+import Highlighter.Highlighter+import UI.Widgets.Common+import UI.Widgets.Editor.Cursor++data EditorMode = InsertMode | ReplaceMode+ deriving (Eq, Show)++data SomeTokenStream where+ SomeTokenStream :: (Show a, Highlightable a) => IO [a] -> SomeTokenStream++data EditorWidget = EditorWidget+ { ewContent :: Text+ , ewDim :: Dimensions+ , ewVisibility :: Bool+ , ewPos :: ScreenPos+ , ewCursor :: Int -- Cursor position offset into content. Starts at 0+ , ewDebugLocation :: Maybe Location+ , ewParseErrorLocation :: Maybe Location+ , ewWordWrap :: Bool+ , eweHasFocus :: Bool+ , ewScrollOffset :: Int+ , ewInsertMode :: EditorMode+ , ewTokenStream :: Maybe SomeTokenStream+ , ewAutocompleteWidget :: Maybe SomeWidgetRef+ , ewAutocompleteSuggestions :: (forall m. MonadIO m => Text -> m [(Text, Text)])+ , ewReadOnly :: Bool+ , ewCursorInfo :: CursorInfo -- Cursor info (location relative to the begining of text)+ , ewSelection :: Maybe (Int, Int)+ , ewShowVirtualCursor :: Bool+ , ewParams :: EditorParams+ , ewCursorLine :: Int -- Line on which the cursor is currently. 1 based+ }++data EditorParams = EditorParams+ { epGutterSize :: Int+ , epLinenumberWidth :: Int+ , epLinenumberRightPad :: Int+ , epBorderSize :: Int+ , epLineNos :: Bool+ }++defaultEp :: EditorParams+defaultEp = EditorParams 1 4 0 1 True++instance Moveable EditorWidget where+ getPos ref = ewPos <$> readWRef ref+ move ref pos = modifyWRef ref (\ew -> ew { ewPos = pos })+ getDim ref = ewDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\low -> low { ewDim = cb $ ewDim low })++instance Widget EditorWidget where+ hasCapability (KeyInputCap _) = Just Dict+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability _ = Nothing++getTextPaddingAndSoftLineLength :: Dimensions -> EditorParams -> (Int, Int)+getTextPaddingAndSoftLineLength d EditorParams {..} = let+ linenumberWidth' = if epLineNos then epLinenumberWidth else 0+ linenumberRightPad' = if epLineNos then epLinenumberRightPad else 0+ textPadding = epBorderSize + epGutterSize + linenumberWidth' + linenumberRightPad'+ softLineLength = (diW d) - textPadding - (2 * epBorderSize)+ in (textPadding, softLineLength)++getContentStart :: EditorParams -> ScreenPos+getContentStart EditorParams {..} = ScreenPos (epBorderSize + epGutterSize) epBorderSize++getTextContentStart :: Dimensions -> EditorParams -> ScreenPos+getTextContentStart d ep = let+ (tp, _) = getTextPaddingAndSoftLineLength d ep+ in addSp (ScreenPos (tp - 1) 0) (getContentStart ep)++instance Drawable EditorWidget where+ setVisibility ref v = modifyWRefM ref (\b -> do+ case ewAutocompleteWidget b of+ Just (SomeWidgetRef acRef) -> withCapability (DrawableCap acRef) $ do+ setVisibility acRef False+ _ -> pure ()+ pure $ b { ewVisibility = v })+ getVisibility ref = ewVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ draw' w+ where+ draw' w = do+ if (diH $ ewDim w) > 2 then drawBorderBox (ewPos w) (ewDim w) else pass+ let (_, softLineLength) = getTextPaddingAndSoftLineLength (ewDim w) params+ let content = ewContent w+ let cursorLine = ewCursorLine w+ let contentHeight = (diH $ ewDim w) - 2++ let mDlocation = ewDebugLocation w+ let mElocation = ewParseErrorLocation w+ let mSelection = ewSelection w+ let mCursorLoc = if (ewShowVirtualCursor w) then Just (ewCursor w) else Nothing+ let contentStartPos = addSp (getContentStart params) (ewPos w)+ case ewTokenStream w of+ Nothing ->+ void $ iterateUntilM isNothing+ (printOneLine @Text params mCursorLoc (epLineNos params) cursorLine mSelection mElocation mDlocation (softLineLength, contentHeight) (ewScrollOffset w) contentStartPos) $ Just (content, 1, 0, 0, [])+ Just (SomeTokenStream (readTokens :: IO [tokenstream])) -> do+ tokens <- liftIO readTokens+ void $ iterateUntilM isNothing+ (printOneLine @tokenstream params mCursorLoc (epLineNos params) cursorLine mSelection mElocation mDlocation (softLineLength, contentHeight) (ewScrollOffset w) contentStartPos) $ Just (content, 1, 0, 0, tokens)++ getCursorInfo ref >>= \case+ Nothing -> pure ()+ Just (cl, _) -> do+ case (ewAutocompleteWidget w) of+ Just (SomeWidgetRef a) ->+ withCapability (DrawableCap a) $ do+ getVisibility a >>= \case+ False -> pure ()+ True -> do+ withCapability (MoveableCap a) $ do+ Dimensions bx by <- getScreenBounds+ Dimensions ax ay <- getDim a+ let+ newAcPos = moveDown 1 cl+ acEndY = sY $ moveDown ay newAcPos+ acEndX = sX $ moveRight ax newAcPos+ rightOf = acEndX - bx+ bottomOf = acEndY - by++ bottomOfFixed = if bottomOf > 0+ then moveUp (ay+1) newAcPos+ else newAcPos++ rightOfFixed = if rightOf > 0+ then moveLeft rightOf bottomOfFixed+ else bottomOfFixed+ move a rightOfFixed+ Nothing -> pure ()+ where+ params = ewParams w++printOneLine+ :: forall a m. (Show a, WidgetC m, Highlightable a)+ => EditorParams+ -> Maybe Int+ -> Bool+ -> Int+ -> Maybe (Int, Int)+ -> Maybe Location+ -> Maybe Location+ -> (Int, Int)+ -> Int+ -> ScreenPos+ -> Maybe (Text, Int, Int, Int, [a])+ -> m (Maybe (Text, Int, Int, Int, [a]))+printOneLine _ _ _ _ _ _ _ _ _ _ Nothing = pure Nothing+printOneLine params@(EditorParams {..}) mCursorLoc showLineNos cursorLine selection errorLocation debugLocation (width, height) scrollOffset startPos (Just (cnt, lnNo, realoffset, hoffset, tokenStack)) = do+ -- Take until next newline+ let hl = T.takeWhile (/= '\n') cnt+ let offset = realoffset - scrollOffset+ case debugLocation of+ Just dLocation -> do+ when (lnNo == lcLine dLocation && ((lnNo - scrollOffset) < height) && ((lnNo - scrollOffset) > 0)) $ do+ wSetCursor $ moveLeft 1 $ moveDown offset startPos+ csPutText (colorTextFg Green ">")+ Nothing -> pure ()+ case errorLocation of+ Just eLocation -> do+ when (lnNo == lcLine eLocation && ((lnNo - scrollOffset) < height) && ((lnNo - scrollOffset) > 0)) $ do+ wSetCursor $ moveLeft 1 $ moveDown offset startPos+ csPutText (colorText White Red "X")+ Nothing -> pure ()+ wSetCursor $ moveDown offset startPos+ when (showLineNos && isPrintableArea offset height) $ do+ let formatstr = "%" <> show linenumberWidth' <> "d"+ if lnNo == cursorLine+ then csPutText $ colorText White Black $ pack $ printf formatstr lnNo+ else csPutText $ Plain $ pack $ printf formatstr lnNo+ let ct = T.chunksOf width hl+ newTokenStack <- foldM (\stk x -> printOneSoftLine params startPos debugLocation selection errorLocation mCursorLoc width height hoffset offset stk x) tokenStack $ DL.zip [0..] ct+ let thisLen = (T.length hl)+ let remaining = T.drop thisLen cnt+ let nextOffset = hoffset + thisLen++ -- Process the new line in stream as well.+ case T.uncons remaining of+ Just ('\n', remaining') -> do+ let (_, newTokenStack') = pairWithTokens @a newTokenStack nextOffset "\n"+ pure $ Just (remaining', lnNo + 1, realoffset + (max 1 (DL.length ct)), nextOffset+1, newTokenStack')+ Just _ -> do+ pure $ Just (remaining, lnNo + 1, realoffset + (max 1 (DL.length ct)), nextOffset, newTokenStack)+ Nothing -> pure Nothing+ where++ linenumberWidth' = if showLineNos then epLinenumberWidth else 0++printOneSoftLine+ :: forall a m . (Highlightable a, WidgetC m)+ => EditorParams+ -> ScreenPos+ -> Maybe Location+ -> Maybe (Int, Int)+ -> Maybe Location+ -> Maybe Int+ -> Int+ -> Int+ -> Int+ -> Int -- The screen position y co-ordinate where the main, real line starts+ -> [a] -- The token stack at this point+ -> (Int, Text) -- The offset of this soft line, and the content+ -> m [a] -- The token stack after printing this soft line+printOneSoftLine EditorParams {..} startPos debugLocation selection errorLocation mCursorLoc width height hoffset startLine tokenStack' (sfOffset, softLine) = do+ let startOffset = hoffset + (sfOffset * width)+ let realoffset' = startLine + sfOffset+ let (hlText, tokenStack'') = pairWithTokens @a tokenStack' startOffset softLine+ if (isPrintableArea realoffset' height)+ then do+ wSetCursor+ $ moveRight (gutterSize + linenumberWidth' + linenumberRightPad')+ $ moveDown realoffset' startPos+ hlText' <- case debugLocation of+ Just dLocation -> do+ pure $ (debugColor dLocation) <$> hlText+ Nothing -> pure ((\(a, b) -> (Plain a, b)) <$> hlText)+ hlText'' <- case selection of+ Just sLocation -> do+ pure $ (selectionColor startOffset sLocation) <$> hlText'+ Nothing -> pure hlText'+ hlText''' <- case errorLocation of+ Just dLocation -> do+ pure $ (errorColor dLocation) <$> hlText''+ Nothing -> pure hlText''+ hlText'''' <- case mCursorLoc of+ Just off -> do+ pure $ (markVirtualCursor startOffset off) <$> hlText'''+ Nothing -> pure hlText'''+ csPutText $ StyledText NoStyle ((highlight @a) <$> hlText'''')+ else+ pure ()+ pure tokenStack''+ where+ gutterSize = epGutterSize+ linenumberWidth = epLinenumberWidth+ linenumberRightPad = epLinenumberRightPad+ linenumberWidth' = if epLineNos then linenumberWidth else 0+ linenumberRightPad' = if epLineNos then linenumberRightPad else 0++ debugColor _ (src, Nothing) = (Plain src, Nothing)+ debugColor debugLoc (src, Just token) = let+ tokenLoc = getTokenLoc token+ in if tokenLoc == debugLoc then (StyledText TextUnderline [Plain src], Just token) else (Plain src, Just token)++ selectionColor :: Int -> (Int, Int) -> (StyledText, Maybe a) -> (StyledText, Maybe a)+ selectionColor startOffset selectionLoc (src, Nothing) =+ let+ newSrc = StyledText NoStyle+ (applyStyleToRange (\st -> StyledText (FgBg Black White) [st]) startOffset selectionLoc [src])+ in (newSrc, Nothing)+ selectionColor _ selectionLoc (src, Just token) =+ let+ newSrc = StyledText NoStyle (applyStyleToRange+ (\st -> StyledText (FgBg Black White) [st]) (lcOffset $ getTokenLoc token) selectionLoc [src])+ in (newSrc, Just token)++ errorColor _ (src, Nothing) = (src, Nothing)+ errorColor errorLoc (src, Just token) = let+ tokenLoc = getTokenLoc token+ in if tokenLoc == errorLoc then (StyledText TextUnderline [src], Just token) else (src, Just token)++ markVirtualCursor :: Int -> Int -> (StyledText, Maybe a) -> (StyledText, Maybe a)+ markVirtualCursor startOffset cursorLoc (src, Nothing) =+ let+ newSrc = StyledText NoStyle+ (applyStyleToRange (\st -> StyledText (Bg Black) [st]) startOffset (cursorLoc, cursorLoc) [src])+ in (newSrc, Nothing)+ markVirtualCursor _ cursorLoc (src, Just token) =+ let+ newSrc = StyledText NoStyle (applyStyleToRange+ (\st -> StyledText (FgBg White Red) [st]) (lcOffset $ getTokenLoc token) (cursorLoc, cursorLoc) [src])+ in (newSrc, Just token)++isPrintableArea :: Int -> Int -> Bool+isPrintableArea y height = y >=0 && y < height++instance KeyInput EditorWidget where+ getCursorInfo ref = do+ ew <- readWRef ref+ let tp = getTextContentStart (ewDim ew) (ewParams ew)+ let (sp, cs) = ewCursorInfo ew+ pure $ Just (addSp (ewPos ew) (addSp tp (moveUp (ewScrollOffset ew) sp)), cs)+ handleInput ref ev = do+ modifyWRefM ref (updateOnInput ev)++instance Container EditorWidget Text where+ getContent ref = ewContent <$> readWRef ref+ setContent ref content = modifyWRef ref (\w -> w { ewContent = content })++between :: Int -> (Int, Int) -> Bool+between a (b, c) = (b <= a) && (a <= c)++insertCharAt :: Char -> Int -> Text -> Text+insertCharAt c offset t = T.append (T.take offset t) (T.cons c (T.drop offset t))++replaceCharAt :: Char -> Int -> Text -> Text+replaceCharAt c offset t = T.append (T.take (max 0 (offset - 1)) t) (T.cons c (T.drop offset t))++removeCharAt :: Int -> Text -> Text+removeCharAt offset t = case T.drop offset t of+ "" -> t+ dropped -> T.append (T.take offset t) (T.tail dropped)++-- TODO: Move this logic to autocomplete handler+getAutoCompleteKey :: (HasLog m, MonadIO m) => Text -> Int -> m Text+getAutoCompleteKey cnt cursoroffset = do+ let contentTillCursor = T.take cursoroffset cnt+ case T.unsnoc contentTillCursor of+ Just (_, ' ') -> pure ""+ _ -> pure $ getLastWord "" contentTillCursor+ where+ getLastWord :: Text -> Text -> Text+ getLastWord r c = case T.unsnoc c of+ Nothing -> r+ Just (p, lc@((\ch -> T.cons ch "") -> lct)) ->+ if lct `T.isInfixOf` " \n(.,+-*/:{"+ then r else getLastWord (T.cons lc r) p++replaceLastWord :: (HasLog m, MonadIO m) => Text -> Int -> Text -> m (Text, Int)+replaceLastWord content cursor replacement = do+ lastword <- getAutoCompleteKey content cursor+ let+ lastWordLen = T.length lastword+ replacementLen = T.length replacement+ let newContent = T.concat [T.take (cursor - lastWordLen) content, replacement, T.drop cursor content]+ pure (newContent, (replacementLen - lastWordLen))++mkRange :: (Int, Int) -> (Int, Int)+mkRange (r1, r2) = (min r1 r2, max r1 r2)++data CursorMovement+ = CVert CursorMovementVertical | CRIGHT Int | CLEFT | CHOME | CEND++data CursorMovementVertical+ = CUP | CDOWN++adjustScrollOffset :: WidgetC m => WRef EditorWidget -> m ()+adjustScrollOffset r =+ modifyWRef r (\ew -> putCursor Nothing 0 ew)++putCursor :: Maybe [Int] -> Int -> EditorWidget -> EditorWidget+putCursor mll nc ew = let+ lineLengths = fromMaybe (getLineLengths ew) mll+ (currentCursorSp, _) = ewCursorInfo ew+ in case offsetToScreenPos contentWidth lineLengths nc of+ Just (newsp, cl) -> let+ newEw = ew { ewCursorLine = cl, ewCursorInfo = (newsp, cStyle), ewCursor = nc }+ newScrollOffset = if (sY currentCursorSp /= sY newsp)+ then computeScrollOffset newEw newsp+ else ewScrollOffset newEw+ in newEw { ewScrollOffset = newScrollOffset }+ Nothing -> ew+ where+ (_, cStyle) = ewCursorInfo ew+ (_, contentWidth) = getTextPaddingAndSoftLineLength (ewDim ew) (ewParams ew)++getContetLines :: Text -> [Text]+getContetLines = T.split (== '\n')++getLineLengths :: EditorWidget -> [Int]+getLineLengths ew =+ let+ contentLines = getContetLines (ewContent ew)+ -- Shoulnd't use T.lines here as behavior is different when the last char is a new line.+ in T.length <$> contentLines++moveCursor :: EditorWidget -> CursorMovement -> EditorWidget+moveCursor ew cm = case cm of+ CVert v -> moveCursorVertical ew v+ CRIGHT o -> newWidget o+ CLEFT -> newWidget (-1)+ CHOME -> let+ newLineOffset = (sum (DL.take (ewCursorLine ew - 1) lineLengths)) + (ewCursorLine ew - 1)+ in newWidget (newLineOffset - currentCursor)+ CEND -> let+ newLineOffset = case T.findIndex (== '\n') (T.drop currentCursor content) of+ Just off -> off+ Nothing -> T.length content - currentCursor+ in newWidget newLineOffset+ where+ newWidget off = let+ nc = min (T.length (ewContent ew)) (currentCursor + off)+ in putCursor (Just lineLengths) nc ew+ currentCursor = ewCursor ew+ lineLengths = getLineLengths ew+ content = ewContent ew++computeScrollOffset :: EditorWidget -> ScreenPos -> Int+computeScrollOffset ew newSp = let+ contentHeight = (diH $ ewDim ew) - (2 * (epBorderSize $ ewParams ew))+ cursorOverflow = (sY newSp - (ewScrollOffset ew)) - (contentHeight - 1)+ cursorUnderflow = (ewScrollOffset ew) - (sY newSp)+ in if cursorOverflow > 0+ then ewScrollOffset ew + cursorOverflow+ else if cursorUnderflow > 0+ then ewScrollOffset ew - cursorUnderflow+ else ewScrollOffset ew++moveCursorVertical :: EditorWidget -> CursorMovementVertical -> EditorWidget+moveCursorVertical ew cm =+ case screenPosToOffset lineLengths contentWidth newSp' of+ Just (newCursor, cursorLine, newSp) -> let+ newScrollOffset = computeScrollOffset ew newSp+ in ew { ewCursorLine = cursorLine, ewScrollOffset = newScrollOffset, ewCursorInfo = (newSp, cStyle), ewCursor = newCursor }+ Nothing -> ew++ where+ newSp' = case cm of+ CUP -> moveUp 1 currentSp+ CDOWN -> moveDown 1 currentSp+ (currentSp, cStyle) = ewCursorInfo ew+ lineLengths = T.length <$> contentLines+ contentLines = getContetLines $ ewContent ew+ (_, contentWidth) = getTextPaddingAndSoftLineLength (ewDim ew) (ewParams ew)++updateOnInput :: forall m. WidgetC m => KeyEvent -> EditorWidget -> m EditorWidget+updateOnInput ev ew = do+ if (ewReadOnly ew)+ then pure ew+ else do+ case ev of+ KeyCtrl _ sh _ ArrowUp -> simpleCursorMovement (CVert CUP) sh+ KeyCtrl _ sh _ ArrowDown -> simpleCursorMovement (CVert CDOWN) sh+ KeyCtrl _ sh _ End -> simpleCursorMovement CEND sh+ KeyCtrl _ sh _ Home -> simpleCursorMovement CHOME sh+ KeyCtrl _ sh _ ArrowRight -> simpleCursorMovement (CRIGHT 1) sh+ KeyCtrl _ sh _ ArrowLeft -> simpleCursorMovement CLEFT sh+ KeyCtrl _ _ _ Del -> do+ let+ existing = ewContent ew+ cursor = ewCursor ew+ let newEw = ew { ewContent = removeCharAt cursor existing }+ checkShowAc newEw+ pure newEw+ KeyCtrl _ _ _ Esc -> do+ hideAc ew+ pure ew+ KeyCtrl _ _ _ Backspace -> if ewCursor ew > 0+ then+ let+ existing = ewContent ew+ cursor = ewCursor ew+ in do+ let newEw = moveCursor (ew { ewContent = removeCharAt (cursor - 1) existing }) CLEFT+ checkShowAc newEw+ pure newEw+ else pure ew+ KeyCtrl _ _ _ Return -> do+ isAutoCompleting ew ev >>= \case+ False -> updateOnInput (KeyChar False False False '\n') ew+ True -> do+ case ewAutocompleteWidget ew of+ Just (SomeWidgetRef ac) ->+ withCapability (SelectableCap ac) $ do+ selection <- getSelection ac+ (newContent, cursorShift) <- replaceLastWord (ewContent ew) (ewCursor ew) selection+ hideAc ew+ pure $ moveCursor (ew { ewContent = newContent }) (CRIGHT cursorShift)+ Nothing -> pure ew+ KeyChar _ _ _ (convertTab -> c) -> case ewInsertMode ew of+ InsertMode -> do+ let newContent = insertCharAt c (ewCursor ew) (ewContent ew)+ let newEw = moveCursor (ew { ewContent = newContent}) (CRIGHT 1)+ checkShowAc newEw+ pure newEw+ ReplaceMode -> pure ew -- disable replace mode now+ _ -> pure ew+ where++ simpleCursorMovement+ :: CursorMovement+ -> Bool+ -> m EditorWidget+ simpleCursorMovement cm sh = do+ isAutoCompleting ew ev >>= \case+ True -> pure ew+ False -> do+ let oldCursor = ewCursor ew+ let newEw = moveCursor ew cm+ let newCursor = ewCursor newEw+ let newSelection = if sh+ then case ewSelection ew of+ Just (ss, _) -> Just $ mkRange (ss, newCursor - 1)+ Nothing -> Just $ mkRange (oldCursor, newCursor - 1)+ else Nothing+ pure $ newEw { ewSelection = newSelection }++ isAutoCompleting ew' key =+ case ewAutocompleteWidget ew' of+ Just (SomeWidgetRef ac) ->+ withCapability (DrawableCap ac) $ do+ getVisibility ac >>= \case+ True -> withCapability (KeyInputCap ac) $ do+ handleInput ac key+ pure True+ False -> pure False+ Nothing -> pure False+ hideAc ew' = do+ case ewAutocompleteWidget ew' of+ Just (SomeWidgetRef ac) ->+ withCapability (DrawableCap ac) $ do+ setVisibility ac False+ Nothing -> pure ()++ checkShowAc ew' = do+ case ewAutocompleteWidget ew' of+ Just (SomeWidgetRef ac) -> do+ key <- getAutoCompleteKey (ewContent ew') (ewCursor ew')+ if T.null key+ then do+ withCapability (DrawableCap ac) $ do+ setVisibility ac False+ else do+ (ewAutocompleteSuggestions ew) key >>= \case+ [] -> do+ withCapability (DrawableCap ac) $ do+ setVisibility ac False+ suggestions@(_:_) -> withCapability (ContainerCap ac (Proxy @[(Text, Text)])) $ do+ setContent ac (sortBy (\(a1, _) (a2, _) -> compare (T.length a1) (T.length a2)) suggestions)+ withCapability (DrawableCap ac) $ do+ setVisibility ac True+ pure ()+ Nothing -> pure ()++ convertTab '\t' = ' '+ convertTab c = c++editor+ :: forall m. WidgetC m+ => (forall m1. MonadIO m1 => Text -> m1 [(Text, Text)])+ -> Maybe SomeTokenStream+ -> m (WRef EditorWidget)+editor mautocomplete mts =+ newWRef $ EditorWidget+ { ewContent = ""+ , ewDim = Dimensions 0 0+ , ewVisibility = True+ , ewPos = ScreenPos 0 0+ , ewCursor = 0+ , ewDebugLocation = Nothing+ , ewParseErrorLocation = Nothing+ , ewWordWrap = True+ , eweHasFocus = False+ , ewScrollOffset = 0+ , ewInsertMode = InsertMode+ , ewTokenStream = mts+ , ewAutocompleteWidget = Nothing+ , ewAutocompleteSuggestions = mautocomplete+ , ewReadOnly = False+ , ewCursorInfo = (ScreenPos 0 0, Bar)+ , ewSelection = Nothing+ , ewShowVirtualCursor = False+ , ewParams = defaultEp+ , ewCursorLine = 1+ }
+ src/UI/Widgets/Editor/Cursor.hs view
@@ -0,0 +1,70 @@+module UI.Widgets.Editor.Cursor where++import qualified Data.List as DL++import Common++offsetToScreenPos+ :: Int -- ^ Content width, where lines longer are wrapped.+ -> [Int] -- ^ Line lengths+ -> Int -- ^ Linear offset into cursor position. This is real offset that starts at 0+ -> Maybe (ScreenPos, Int) -- Screen pos and actual line in content where cursor is at+offsetToScreenPos _ [] _ = Just $ (ScreenPos 0 0, 1)+offsetToScreenPos _ _ 0 = Just $ (ScreenPos 0 0, 1)+offsetToScreenPos width lns offset =+ let (sp, _, _, _) = DL.foldl' foldFn (Nothing, 0, 0, 1) lns in sp+ where+ foldFn :: (Maybe (ScreenPos, Int), Int, Int, Int) -> Int -> (Maybe (ScreenPos, Int), Int, Int, Int)+ foldFn a@(Just _, _, _, _) _ = a+ foldFn (Nothing, leftOffset, lineCount, realLineCount) lineLength =+ case DL.foldl' foldFn' (Nothing, leftOffset, lineCount) (brokenLines width lineLength) of+ (Just a, _, _) -> (Just (a, realLineCount), 0, 0, 0)+ (Nothing, lo, lc) -> (Nothing, lo, lc, realLineCount+1)++ foldFn' :: (Maybe ScreenPos, Int, Int) -> Int -> (Maybe ScreenPos, Int, Int)+ foldFn' a@(Just _, _, _) _ = a+ foldFn' (Nothing, leftOffset, lineCount) lineLength =+ let rightOffset = leftOffset + lineLength - 1+ in if offset >= leftOffset && offset <= rightOffset+ then (Just $ ScreenPos (offset - leftOffset) lineCount, 0, 0)+ else (Nothing, rightOffset+1, lineCount+1)++brokenLines :: Int -> Int -> [Int]+brokenLines _ 0 = [1]+brokenLines width ll = let+ (flc, lll) = divMod ll width+ in if lll > 0+ -- We add one char to the very endline to signify the ending newline.+ -- and to allow positioning of cursor the very last char in a line.+ then replicate flc width <> [lll+1]+ else replicate (flc - 1) width <> [width + 1]++screenPosToOffset+ :: [Int] -- ^ Line lengths+ -> Int -- ^ Content width, where lines longer are wrapped.+ -> ScreenPos -- ^ Screen position relative to top left edget of content.+ -> Maybe (Int, Int, ScreenPos) -- Offset starting at zero, cursor line, and adjusted ScreenPos so cursor is at end of line+screenPosToOffset lns width (ScreenPos x y) =+ let (sp, _, _, _) = DL.foldl' foldFn (Nothing, 0, 0, 1) lns in sp+ where+ foldFn :: (Maybe (Int, Int, ScreenPos), Int, Int, Int) -> Int -> (Maybe (Int, Int, ScreenPos), Int, Int, Int)+ foldFn a@(Just _, _, _, _) _ = a+ foldFn (Nothing, lineCount, leftOffset, currentLine) lineLength =+ case DL.foldl' foldFn' (Nothing, lineCount, leftOffset) (brokenLines width lineLength) of+ (Nothing, a, b) -> (Nothing, a, b, currentLine + 1)+ (Just (a, b), _, _) -> (Just (a, currentLine, b), 0, 0, 0)++ foldFn'+ :: ( Maybe (Int, ScreenPos) -- Result+ , Int -- current screen line no+ , Int -- current offset at line start+ )+ -> Int -- current line width+ -> (Maybe (Int, ScreenPos), Int, Int)+ foldFn' a@(Just _, _, _) _ = a+ foldFn' (Nothing, lno, offset) lw =+ if lno == y+ then let+ aOffset = min (lw - 1) x+ in (Just (offset + aOffset, ScreenPos aOffset y), 0, 0)+ else (Nothing, lno+1, offset+lw)
+ src/UI/Widgets/Layout.hs view
@@ -0,0 +1,138 @@+module UI.Widgets.Layout where++import Data.Coerce+import Data.Map.Ordered as OMap+import Data.Maybe++import Common+import UI.Widgets.Common++data Orientation+ = Vertical+ | Horizontal++newtype ContentId = ContentId Text+ deriving (Show, Ord, Eq)++data LayoutWidget = LayoutWidget+ { lowDim :: Dimensions+ , lowPos :: ScreenPos+ , lowContent :: OMap ContentId SomeWidgetRef+ , lowOrientation :: Orientation+ , lowTextFocus :: Maybe SomeKeyInputWidget+ , lowVisibility :: Bool+ , lowFloatingContent :: Maybe SomeWidgetRef+ , lowDimensionDistribution :: Int -> [Double]+ }++instance Layout LayoutWidget where+ addWidget ref (coerce -> contentId) child =+ modifyWRef ref (\low -> low { lowContent = (lowContent low) |> (contentId, (SomeWidgetRef child)) })+ setTextFocus ref (coerce -> child) = do+ w <- readWRef ref+ case OMap.lookup child (lowContent w) of+ Nothing -> pure ()+ Just (SomeWidgetRef ti) ->+ withCapability (KeyInputCap ti) $+ modifyWRef ref (\low -> low { lowTextFocus = Just $ SomeKeyInputWidget ti })++instance KeyInput LayoutWidget where+ getCursorInfo _ = pure Nothing+ handleInput ref kv = do+ w <- readWRef ref+ case lowTextFocus w of+ Just (SomeKeyInputWidget tr) -> handleInput tr kv+ Nothing -> pure ()++instance Widget LayoutWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability (KeyInputCap _) = Just Dict+ hasCapability _ = Nothing++instance Moveable LayoutWidget where+ getPos ref = lowPos <$> readWRef ref+ move ref pos =+ modifyWRef ref (\low -> low { lowPos = pos })+ getDim ref =+ lowDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\low -> low { lowDim = cb $ lowDim low })++instance Drawable LayoutWidget where+ setVisibility ref v = modifyWRef ref (\b -> b { lowVisibility = v })+ getVisibility ref = lowVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ let+ dimension = case lowOrientation w of+ Vertical -> (diH $ lowDim w)+ Horizontal -> (diW $ lowDim w)+ visibileItems <- catMaybes <$> mapM (\(sw@(SomeWidgetRef cw)) -> case hasCapability (DrawableCap cw) of+ Just Dict -> do+ b <- getVisibility cw+ case b of+ True -> pure $ Just sw+ _ -> pure Nothing+ Nothing -> pure Nothing) (snd <$> (OMap.assocs $ lowContent w))++ let+ itemCount = Prelude.length visibileItems+ dimensionDistribution = lowDimensionDistribution w itemCount+ resizeCallback d = case lowOrientation w of+ Vertical -> (\dm -> dm { diW = diW $ lowDim w , diH = d})+ Horizontal -> (\dm -> dm { diH = diH $ lowDim w, diW = d })++ foldM_ (\totalDim (idx, (fraction, (SomeWidgetRef cw))) ->+ withCapability (MoveableCap cw) $ do+ let thisDim' =+ if (idx == itemCount) then (dimension - totalDim) else round $ (realToFrac dimension) * fraction+ let thisDim = max thisDim' 3+ resize cw (resizeCallback thisDim)+ pure (totalDim + thisDim)+ ) 0 (Prelude.zip [1..] (Prelude.zip dimensionDistribution visibileItems))++ case (lowOrientation w) of+ Vertical -> foldM_ (fny (sX $ lowPos w)) (sY $ lowPos w) visibileItems+ Horizontal -> foldM_ (fn (sY $ lowPos w)) (sX $ lowPos w) visibileItems+ case lowFloatingContent w of+ Just (SomeWidgetRef f) -> do+ withCapability (DrawableCap f) $ do+ draw f+ Nothing -> pure ()+ where+ fny x y w = case w of+ SomeWidgetRef a ->+ withCapability (MoveableCap a) $+ withCapability (DrawableCap a) $ do+ dim <- getDim a+ move a (ScreenPos { sY = y, sX = x })+ draw a+ pure (y + (diH dim))+ fn y x w = case w of+ SomeWidgetRef a ->+ withCapability (MoveableCap a) $+ withCapability (DrawableCap a) $ do+ dim <- getDim a+ move a (ScreenPos { sY = y, sX = x })+ draw a+ pure (x + (diW dim))++layoutWidget+ :: WidgetC m+ => Orientation+ -> (Int -> [Double])+ -> Maybe SomeKeyInputWidget+ -> m (WRef LayoutWidget)+layoutWidget ori distr tif = do+ newWRef $+ LayoutWidget+ { lowDim = Dimensions 0 0+ , lowPos = origin+ , lowContent = OMap.empty+ , lowOrientation = ori+ , lowTextFocus = tif+ , lowVisibility = True+ , lowFloatingContent = Nothing+ , lowDimensionDistribution = distr+ }
+ src/UI/Widgets/LogWidget.hs view
@@ -0,0 +1,81 @@+module UI.Widgets.LogWidget where++import Data.Text as T+import Text.Printf (printf)+import System.Console.ANSI (Color(..))+import Common+import Highlighter.Highlighter+import UI.Widgets.Common as C++data LogWidget = LogWidget+ { lwDim :: Dimensions+ , lwContent :: [Text]+ , lwPos :: ScreenPos+ , lwVisible :: Bool+ , lwScrollOffset :: Int+ }++insertLog :: WidgetC m => WRef LogWidget -> Text -> m ()+insertLog ref l = modifyWRef ref (\lw ->+ let+ h = diH $ lwDim lw+ ln = Prelude.length (lwContent lw)+ newContent = (lwContent lw) ++ [l]+ in if ln > h then lw { lwScrollOffset = 0, lwContent = Prelude.drop (ln - h) newContent } else lw { lwContent = newContent })++instance Moveable LogWidget where+ getPos ref = lwPos <$> readWRef ref+ move ref sp =+ modifyWRef ref (\ww -> ww { lwPos = sp })+ getDim ref =+ lwDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\ww -> ww { lwDim = cb $ lwDim ww })++instance Widget LogWidget where+ hasCapability (MoveableCap _) = Just Dict+ hasCapability (DrawableCap _) = Just Dict+ hasCapability _ = Nothing++instance Drawable LogWidget where+ setVisibility ref v = modifyWRef ref (\b -> b { lwVisible = v })+ getVisibility ref = lwVisible <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ let height = (diH $ lwDim w) - 3+ let width = (diW $ lwDim w) - 3+ let scrollOffset = lwScrollOffset w+ drawBorderBox (lwPos w) (lwDim w)+ wSetCursor $ moveDown 1 $ moveRight 1 (lwPos w)+ let fmt = "%-" <> (show (width + 1)) <> "s"+ csPutText $ colorText White Black (T.pack $ printf fmt (" Logs" :: Text))+ let lines' = Prelude.concat $ T.splitOn "\n" <$> lwContent w+ lst <- foldM (\offset line -> do+ let chunksize = (diW $ lwDim w) - 2+ let segments = T.chunksOf chunksize line+ foldM (\soffset chunk -> do+ when ((soffset > scrollOffset) && ((soffset - scrollOffset) <= height) ) $ do+ let cp = moveUp scrollOffset $ moveDown (soffset + 1) $ moveRight 1 (lwPos w)+ wSetCursor cp+ csPutText $ Plain (T.replicate chunksize " ")+ wSetCursor cp+ csPutText $ Plain (T.strip chunk)+ pure (soffset + 1)+ ) offset segments+ ) 1 lines'+ let overflow = (((lst - 1) - scrollOffset) - height)+ when (overflow > 0) $ do+ modifyWRef ref (\a -> a { lwScrollOffset = lwScrollOffset a + overflow })+ draw ref++logWidget+ :: forall m. WidgetM m (WRef LogWidget)+logWidget = do+ newWRef $+ LogWidget+ { lwDim = Dimensions 10 10+ , lwContent = []+ , lwPos = ScreenPos 0 0+ , lwVisible = True+ , lwScrollOffset = 0+ }
+ src/UI/Widgets/MenuContainer.hs view
@@ -0,0 +1,107 @@+module UI.Widgets.MenuContainer where++import qualified Data.Text as T+import System.Console.ANSI (Color(..))+import Text.Printf++import Common+import Highlighter.Highlighter+import UI.Widgets.Common as C++type KeyHandler = forall m. WidgetC m => KeyEvent -> WRef MenuContainerWidget -> m Bool+type SelectionHandler = forall m. WidgetC m => WRef MenuContainerWidget -> (Int, Int) -> m ()++data SubMenu = SubMenu [Text]++data Menu = Menu+ { menuItems :: [(Text, SubMenu)]+ , menuActive :: Maybe (Int, Int) -- Menu items and sub items are indexed from 0+ }++data MenuContainerWidget = MenuContainerWidget+ { mcwDim :: Dimensions+ , mcwContent :: SomeWidgetRef+ , mcwMenu :: Menu+ , mcwSelectionHandler :: SelectionHandler+ , mcwVisibility :: Bool+ }++instance Container MenuContainerWidget SomeWidgetRef where+ setContent ref c =+ modifyWRef ref (\mcw -> mcw { mcwContent = c })+ getContent ref = mcwContent <$> readWRef ref++getSubmenuAt :: Menu -> Int -> Maybe SubMenu+getSubmenuAt (Menu mis _) x =+ case safeIndex mis x of+ Just (_, sm) -> Just sm+ Nothing -> Nothing++getMenuItem :: Menu -> (Int, Int) -> Maybe [Text]+getMenuItem (Menu mis _) (x, y) =+ case safeIndex mis x of+ Just (mmName, SubMenu sm) -> case safeIndex sm y of+ Just sName -> Just [mmName, sName]+ Nothing -> Nothing+ Nothing -> Nothing++instance Widget MenuContainerWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability _ = Nothing++instance Drawable MenuContainerWidget where+ draw :: forall m. WidgetC m => WRef MenuContainerWidget -> m ()+ setVisibility ref v = modifyWRef ref (\b -> b { mcwVisibility = v })+ getVisibility ref = mcwVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ case mcwMenu w of+ Menu mi _ -> foldM_ (\x (n, _) -> do+ csSetCursorPosition x 0+ csPutText (colorText White Black (" "<> n <> " "))+ pure (x + (T.length n + 2))+ ) 1 mi+ case mcwContent w of+ SomeWidgetRef a -> do+ withCapability (DrawableCap a) $ do+ withCapability (MoveableCap a) $ do+ move a (ScreenPos 0 1)+ resize a (\_ -> amendHeight (mcwDim w) (\x -> x-2))+ draw a+ case menuActive $ mcwMenu w of+ Just (m, s) -> do+ case mcwMenu w of+ Menu mi _ -> foldM_ (\(idx, x) (n, submenu) -> do+ if idx == m then do+ case submenu of+ SubMenu smi -> do+ let wi = max 30 (Prelude.maximum $ T.length <$> ("": smi))+ csSetCursorPosition x 0+ drawBorderBox (ScreenPos x 1) (Dimensions (wi + 2) (Prelude.length smi + 2))+ foldM_ (\idy n' -> do+ csSetCursorPosition (x + 1) (idy + 2)+ let stx = "%-" <> (show wi) <> "s"+ let cnt = " "<> n'+ if idy == s+ then csPutText (colorText White Black (T.pack $ printf stx cnt))+ else csPutText (colorTextFg White (T.pack $ printf stx cnt))+ pure (idy+1)) 0 smi+ else pure ()+ pure (idx + 1, x + T.length n + 2)+ ) (0, 1) mi+ Nothing -> pure ()++menuContainer+ :: SomeWidgetRef+ -> Menu+ -> SelectionHandler+ -> WidgetM m (WRef MenuContainerWidget)+menuContainer child menu handler = do+ newWRef $+ MenuContainerWidget+ { mcwDim = Dimensions 0 0+ , mcwContent = child+ , mcwMenu = menu+ , mcwSelectionHandler = handler+ , mcwVisibility = True+ }
+ src/UI/Widgets/NullWidget.hs view
@@ -0,0 +1,25 @@+module UI.Widgets.NullWidget where++import Common+import UI.Widgets.Common++data NullWidget = NullWidget { nwDimensions :: Dimensions, nwPos :: ScreenPos }++instance Widget NullWidget where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability _ = Nothing++instance Moveable NullWidget where+ move _ _ = pure ()+ getPos r = nwPos <$> readWRef r+ getDim r = nwDimensions <$> readWRef r+ resize r fn = modifyWRef r (\w -> w { nwDimensions = fn (nwDimensions w) })++instance Drawable NullWidget where+ setVisibility _ _ = pure ()+ getVisibility _ = pure True+ draw _ = pure ()++nullWidget :: NullWidget+nullWidget = NullWidget (Dimensions 0 0) (ScreenPos 0 0)
+ src/UI/Widgets/TextContainer.hs view
@@ -0,0 +1,50 @@+module UI.Widgets.TextContainer where++import UI.Widgets.Common+import Common++data TextContainerWidget = TextContainerWidget+ { tcwContent :: Text+ , tcwDim :: Dimensions+ , tcwPos :: ScreenPos+ , tcwVisibility :: Bool+ }++instance Container TextContainerWidget Text where+ setContent ref t = do+ modifyWRef ref (\tcw -> tcw { tcwContent = t })+ getContent ref =+ tcwContent <$> readWRef ref++instance Widget TextContainerWidget where+ hasCapability _ = Nothing++instance Moveable TextContainerWidget where+ getPos ref = tcwPos <$> readWRef ref+ move ref pos =+ modifyWRef ref (\tcw -> tcw { tcwPos = pos })+ getDim ref = tcwDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\tcw -> tcw { tcwDim = cb $ tcwDim tcw })++instance Drawable TextContainerWidget where+ setVisibility ref v = modifyWRef ref (\b -> b { tcwVisibility = v })+ getVisibility ref = tcwVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ foldM_ (printOneLine w) 0 (splitOn "\n" (tcwContent w))+ where+ printOneLine w ln lineContent = do+ ll <- foldM printOneSoftLine ln (Prelude.zip (chunksOf ((diW $ tcwDim w) - 2) lineContent) [0..])+ pure (ll + 1)+ where+ printOneSoftLine lns (sLineContent, ln') = do+ wSetCursor $ moveDown (lns + ln') (tcwPos w)+ csPutText $ Plain sLineContent+ pure lns++textContainer+ :: ScreenPos+ -> Dimensions+ -> WidgetM m (WRef TextContainerWidget)+textContainer sp dim = newWRef $ TextContainerWidget "" dim sp True
+ src/UI/Widgets/WatchWidget.hs view
@@ -0,0 +1,59 @@+module UI.Widgets.WatchWidget where++import Data.Proxy (Proxy)+import Data.Typeable (eqT, (:~:)(..))+import Data.Text as T++import Common+import UI.Widgets.Common as C++data WatchWidget = WatchWidget+ { wwDim :: Dimensions+ , wwContent :: [(Text, Text)]+ , wwPos :: ScreenPos+ , wwVisible :: Bool+ }++instance Container WatchWidget [(Text, Text)] where+ setContent ref c =+ modifyWRef ref (\ww -> ww { wwContent = c })+ getContent ref = wwContent <$> readWRef ref++instance Moveable WatchWidget where+ getPos ref = wwPos <$> readWRef ref+ move ref sp =+ modifyWRef ref (\ww -> ww { wwPos = sp })+ getDim ref =+ wwDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\ww -> ww { wwDim = cb $ wwDim ww })++instance Widget WatchWidget where+ hasCapability (MoveableCap _) = Just Dict+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (ContainerCap _ (_ :: Proxy cnt)) = case eqT @cnt @([(Text, Text)]) of+ Just Refl -> Just Dict+ Nothing -> Nothing+ hasCapability _ = Nothing++instance Drawable WatchWidget where+ setVisibility ref v = modifyWRef ref (\b -> b { wwVisible = v })+ getVisibility ref = wwVisible <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ drawBorderBox (wwPos w) (wwDim w)+ wSetCursor $ moveDown 1 $ moveRight 1 (wwPos w)+ flip mapM_ (Prelude.zip [1..] (wwContent w)) $ \(i, (k, v)) -> do+ wSetCursor $ moveDown i $ moveRight 1 (wwPos w)+ csPutText $ Plain $ T.take ((diW $ wwDim w) - 2) $ T.intercalate "|" [k, v]++watchWidget+ :: forall m. WidgetM m (WRef WatchWidget)+watchWidget = do+ newWRef $+ WatchWidget+ { wwDim = Dimensions 10 10+ , wwContent = []+ , wwPos = ScreenPos 0 0+ , wwVisible = False+ }
+ test/Common.hs view
@@ -0,0 +1,33 @@+module Common where++import "spade" Common+import Control.Monad.IO.Class+import Data.Text as T+import Parser+import Test.Common+import Test.Hspec.Hedgehog++import Compiler.AST.Parser.Common++specGenerateAndParse :: forall a.(Show a, Eq a, HasParser a, HasGen a, ToSource a) => Spec+specGenerateAndParse = modifyMaxSuccess (const 100) $ describe "Parser for element" $+ it "can parse generated code" $ hedgehog $ do+ e <- forAll (getGen @a)+ r <- liftIO $ runParser parser $ toTextWithOffset (toSource e)+ footnote $ "Failed source: " <> (T.unpack $ toSource e)+ footnote $ "Tokens: " <> (show e)+ r === (Just e)++specGenerateAndParseAst :: forall a.(Show a, Eq a, HasAstParser a, HasGen a, ToSource a) => Spec+specGenerateAndParseAst = modifyMaxSuccess (const 100) $ describe "Parser for code" $+ it "can parse generated code <> ast" $ hedgehog $ do+ e <- forAll (getGen @a)+ let src = toSource e+ (r, tokens) <- liftIO $ runParserEither parser (toTextWithOffset src) >>= \case+ Right tokens -> do+ r <- runParserEither astParser (mkAstParserState tokens)+ pure (r, tokens)+ Left err -> error $ "Tokinzer failed" <> (show err)+ footnote $ "Failed source: " <> (T.unpack src)+ footnote $ "Tokens: " <> (show tokens)+ (r === (Right e))
+ test/Compiler/AST/ParserSpec.hs view
@@ -0,0 +1,11 @@+module Compiler.AST.ParserSpec where++import Common+import Compiler.AST.Program+import Test.Hspec++spec :: Spec+spec = do+ specGenerateAndParseAst @Expression+ specGenerateAndParseAst @FunctionDef+ specGenerateAndParseAst @ProgramStatement
+ test/Compiler/Lexer/CommentsSpec.hs view
@@ -0,0 +1,18 @@+module Compiler.Lexer.CommentsSpec where++import Test.Hspec++import "spade" Common+import Compiler.Lexer.Comments+import Compiler.Lexer.Tokens+import Compiler.Lexer.Whitespaces+import Parser.Lib+import Parser.Parser++spec :: Spec+spec = do+ describe "Comments parsing" $ do+ it "can parse simple comment" $ runParser parser ("-- comment" :: TextWithOffset) `shouldReturn` (Just $ Comment "comment")+ it "can parse simple consecutive comments" $ runParser parser ("-- comment\n-- comment 2" :: TextWithOffset) `shouldReturn` (Just $ [Comment "comment", Comment "comment 2"])+ it "can parse simple consecutive indented comments" $ runParser @[Token] parser (" -- comment\n -- comment 2" :: TextWithOffset) `shouldReturn`+ (Just $ [Token {tkRaw = TkWhitespace (Space 3), tkLocation = emptyLocation, tkOffsetEnd = 3},Token {tkRaw = TkComment (Comment "comment"), tkLocation = emptyLocation, tkOffsetEnd = 14},Token {tkRaw = TkWhitespace (Space 3), tkLocation = emptyLocation, tkOffsetEnd = 17},Token {tkRaw = TkComment (Comment "comment 2"), tkLocation = emptyLocation, tkOffsetEnd = 30}])
+ test/Compiler/Lexer/DelimeterSpec.hs view
@@ -0,0 +1,9 @@+module Compiler.Lexer.DelimeterSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Delimeters++spec :: Spec+spec = specGenerateAndParse @Delimeter
+ test/Compiler/Lexer/IdentifierSpec.hs view
@@ -0,0 +1,9 @@+module Compiler.Lexer.IdentifierSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Identifiers++spec :: Spec+spec = specGenerateAndParse @Identifier
+ test/Compiler/Lexer/KeywordSpec.hs view
@@ -0,0 +1,9 @@+module Compiler.Lexer.KeywordSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Keywords++spec :: Spec+spec = specGenerateAndParse @Keyword
+ test/Compiler/Lexer/LiteralSpec.hs view
@@ -0,0 +1,26 @@+module Compiler.Lexer.LiteralSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Literals+import Parser.Lib+import Parser.Parser++spec :: Spec+spec = do+ let+ unwrapParseError :: Either (ParseErrorWithParsed a) a -> Either ParseError a+ unwrapParseError (Right a) = Right a+ unwrapParseError (Left a) = Left $ parseError a++ describe "Literal parsing" $ do+ it "can parse strings" $ runParser parser ("\"test\"" :: TextWithOffset) `shouldReturn` (Just $ LitString "test")+ it "can parse numbers" $ runParser parser "90" `shouldReturn` (Just $ LitNumber 90)+ it "reject numbers starting with 0" $ (runParser @Literal) parser "09" `shouldReturn` Nothing+ it "can parse float: 1" $ runParser parser "90.05" `shouldReturn` (Just $ LitFloat 90.05)+ it "can parse float: 2" $ runParser parser "0.05" `shouldReturn` (Just $ LitFloat 0.05)+ it "reject float without leading zero" $ (unwrapParseError <$> runParserEither @TextWithOffset @Literal parser ".05") `shouldReturn` (Left CantHandle)+ it "can parse bool:true" $ runParser parser "true" `shouldReturn` (Just $ LitBool True)+ it "can parse bool:false" $ runParser parser "false" `shouldReturn` (Just $ LitBool False)+ specGenerateAndParse @Literal
+ test/Compiler/Lexer/OperatorSpec.hs view
@@ -0,0 +1,9 @@+module Compiler.Lexer.OperatorSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Operators++spec :: Spec+spec = specGenerateAndParse @Operator
+ test/Compiler/Lexer/TokenSpec.hs view
@@ -0,0 +1,9 @@+module Compiler.Lexer.TokenSpec where++import Test.Hspec++import Common+import Compiler.Lexer.Tokens++spec :: Spec+spec = specGenerateAndParse @[Token]
+ test/Interpreter/InterpreterSpec.hs view
@@ -0,0 +1,55 @@+module Interpreter.InterpreterSpec where++import Test.Hspec+import NeatInterpolation++import Compiler.Parser+import Interpreter+import Interpreter.Interpreter+import Interpreter.Common+++spec :: Spec+spec = do+ describe "While loop" $ do+ it "loops as expected" $ do+ let program = [text|+ let a = 100+ while a > 10+ let a = a - 1+ endwhile+ |]+ compile program >>= interpret'' >>= ensureVarIs (SkIdentifier "a") (NumberValue $ NumberInt 10)++ it "breaks as expected" $ do+ let program = [text|+ let a = 100+ while a > 10+ let a = a - 1+ if a == 20 then+ break+ endif+ endwhile+ |]+ compile program >>= interpret'' >>= ensureVarIs (SkIdentifier "a") (NumberValue $ NumberInt 20)++ it "break only exist one nesting" $ do+ let program = [text|+ let a = 100+ while a > 10+ let b = 100+ let a = a - 1+ while true+ let b = b - 1+ if b == 20 then+ break+ endif+ endwhile+ endwhile+ |]+ compile program >>= interpret'' >>= ensureVarIs (SkIdentifier "a") (NumberValue $ NumberInt 10)+ where+ interpret'' = interpret_ (error "Input stream not available")++ensureVarIs :: ScopeKey -> Value -> InterpreterState -> Expectation+ensureVarIs sk v (isGlobalScope -> scope) = (lookupInTopScope sk [scope]) `shouldBe` (Just v)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/UI/EditorSpec.hs view
@@ -0,0 +1,185 @@+module UI.EditorSpec where++import qualified Data.List as DL+import qualified Data.Vector.Mutable as MV+import System.Console.ANSI (Color(..))+import Test.Hspec+import Test.Hspec.Hedgehog++import "spade" Common+import Compiler.Lexer+import Compiler.Parser (tokenize)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Hedgehog.Gen (int, list)+import Hedgehog.Range (linear)+import UI.Widgets.Common as C+import UI.Widgets.Editor+import UI.Widgets.Editor.Cursor++data ReferenceScreenState = ReferenceScreenState+ { rssLines :: [[StyledText]]+ , rssCursorInfo :: CursorInfo+ }++assertReferenceScreenState :: ReferenceScreenState -> WRef EditorWidget -> WidgetM IO ()+assertReferenceScreenState ReferenceScreenState {..} ewRef = do+ EditorWidget {..} <- readWRef ewRef+ ss <- wsScreenState <$> get+ let linesRef = (ssLines ss)+ lines' <- MV.foldr'(:) [] linesRef+ liftIO $ if lines' == rssLines then do+ T.putStrLn $ "Got expected screen\n" <> (renderLines rssLines)+ else expectationFailure $ "Screens differ, expected:\n" <> (T.unpack $ renderLines rssLines) <> "\nBut got\n" <> (T.unpack $ renderLines lines') <> "\n" <> show lines'+ liftIO $ ewCursorInfo `shouldBe` rssCursorInfo++testEditor :: Text -> [KeyEvent] -> ReferenceScreenState -> Expectation+testEditor content kEvents expectedSs = do+ runWidgetM $ do+ csInitialize $ Dimensions 18 10+ ewRef <- editor (\_ -> pure []) Nothing+ modifyWRef ewRef (\ew -> ew { ewPos = ScreenPos 0 0, ewDim = Dimensions 18 10, ewContent = content })+ csClear+ mapM_ (handleInput ewRef) kEvents+ draw ewRef+ assertReferenceScreenState expectedSs ewRef++mkKeys :: Int -> CtrlKey -> [KeyEvent]+mkKeys count' ctrlKey = DL.take count' $ DL.repeat (KeyCtrl False False False ctrlKey)++mkCharKeys :: Int -> Char -> [KeyEvent]+mkCharKeys count' c = DL.take count' $ DL.repeat (KeyChar False False False c)++spec :: Spec+spec = do+ modifyMaxSuccess (const 100) $ describe "Screenpos round tripping" $+ it "has consitent behavior" $ hedgehog $ do+ lineWidths <- forAll (list (linear 0 5) (int (linear 0 10)))+ offset <- forAll (int (linear 0 10))+ -- liftIO $ putStrLn $ show (lineWidths, offset)+ case offsetToScreenPos 5 lineWidths offset of+ Just (sp, _) -> case screenPosToOffset lineWidths 5 sp of+ Just (offset', _, _) -> do+ footnote $ "Failed data: " <> (show lineWidths)+ (offset === offset')+ Nothing -> pure ()+ Nothing -> pure ()++ describe "Editor Behavior" $ do+ let expected = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "abcd"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when content length is less than width and no key pressed" $ do+ -- Cursor is at the begining of text on load.+ testEditor "abcd" [] (ReferenceScreenState expected (ScreenPos 0 0, Bar))+ it "when content length is less than width and left key pressed" $ do+ -- Cursor remains at the begining, even when left arrow is pressed, because there is no space on left.+ testEditor "abcd" (mkKeys 1 ArrowLeft) (ReferenceScreenState expected (ScreenPos 0 0, Bar))+ it "when content length is less than width and right key pressed" $ do+ -- Cursor moves one place right when right arrow is pressed.+ testEditor "abcd" (mkKeys 1 ArrowRight) (ReferenceScreenState expected (ScreenPos 1 0, Bar))++ let expected_1 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "abcd"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 2",Plain " ",StyledText NoStyle [Plain "efgh"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when there is two lines and no key pressed" $ do+ testEditor "abcd\nefgh" [] (ReferenceScreenState expected_1 (ScreenPos 0 0, Bar))+ it "when there is two lines and 4 right arrow pressed" $ do+ -- After four right arrows, Cursor is just beyond the last char in first line.+ testEditor "abcd\nefgh" (mkKeys 4 ArrowRight) (ReferenceScreenState expected_1 (ScreenPos 4 0, Bar))+ it "when there is two lines and 5 right arrow pressed" $ do+ let expectedSecondLineActive = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",Plain " 1",Plain " ",StyledText NoStyle [Plain "abcd"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 2"],Plain " ",StyledText NoStyle [Plain "efgh"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ -- After five right arrows, Cursor wraps to the start of the next line.+ testEditor "abcd\nefgh" (mkKeys 5 ArrowRight) (ReferenceScreenState expectedSecondLineActive (ScreenPos 0 1, Bar))++ let expected_2 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "abcd 12345"],Plain "\9474"],[Plain "\9474",Plain " ",StyledText NoStyle [Plain "6789"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 2",Plain " ",StyledText NoStyle [Plain "efgh"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when there is two lines and first line is longer than width and no key pressed" $ do+ -- The long line wrap into the line below.+ testEditor "abcd 123456789\nefgh" [] (ReferenceScreenState expected_2 (ScreenPos 0 0, Bar))+ it "when there is two lines and first line is longer than width and right arrow pressed beyond screen width" $ do+ -- TODO: Ideally it should move to ScreenPos 7 2, but right now it goes to ScreenPos 8 2.+ testEditor "abcd 123456789\nefgh" (mkKeys 11 ArrowRight) (ReferenceScreenState expected_2 (ScreenPos 1 1, Bar))+ it "when there is two lines and first line is longer than width and down arrow pressed" $ do+ let expected' = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "abcd 12345"],Plain "\9474"],[Plain "\9474",Plain " ",StyledText NoStyle [Plain "6789"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 2",Plain " ",StyledText NoStyle [Plain "efgh"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ -- The cursor moves into the part of the same line.+ testEditor "abcd 123456789\nefgh" (mkKeys 1 ArrowDown) (ReferenceScreenState expected' (ScreenPos 0 1, Bar))++ let expected_3 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "abcdefghij"],Plain "\9474"],[Plain "\9474",Plain " ",Plain " 2",Plain " ",StyledText NoStyle [Plain "klm"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when one line length is exactly same as width and there is a second line" $ do+ testEditor "abcdefghij\nklm" [] (ReferenceScreenState expected_3 (ScreenPos 0 0, Bar))++ let expected_4 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "backspace erases last char" $ do+ -- Cursor is at the begining of text on load.+ testEditor "" (mkCharKeys 1 'a' <> mkKeys 1 Backspace) (ReferenceScreenState expected_4 (ScreenPos 0 0, Bar))++ let expected_5 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 1"],Plain " ",StyledText NoStyle [Plain "a"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when initial content is empty and a key is pressed" $ do+ -- Cursor is at the begining of text on load.+ testEditor "" (mkCharKeys 1 'a') (ReferenceScreenState expected_5 (ScreenPos 1 0, Bar))++ let expected_6 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",Plain " 1",Plain " ",StyledText NoStyle [Plain "aaa"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 2"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when enter key is pressed at the end of a line" $ do+ -- Cursor is at the begining of text on load.+ testEditor "" (mkCharKeys 3 'a' <> mkKeys 1 Return) (ReferenceScreenState expected_6 (ScreenPos 0 1, Bar))++ let expected_7 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",Plain " 1",Plain " ",StyledText NoStyle [Plain "aaa"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 2"],Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when down arrow key is pressed at the start of a line and the next line is empty" $ do+ -- Cursor is at the begining of text on load.+ testEditor "" (mkCharKeys 3 'a' <> mkKeys 1 Return <> mkKeys 1 ArrowUp <> mkKeys 1 ArrowDown) (ReferenceScreenState expected_7 (ScreenPos 0 1, Bar))++ let expected_8 = [[Plain "\9484\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9488"],[Plain "\9474",Plain " ",Plain " 2",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 3",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 4",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 5",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 6",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 7",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",Plain " 8",Plain " ",Plain "\9474"],[Plain "\9474",Plain " ",StyledText (FgBg White Black) [Plain " 9"],Plain " ",Plain "\9474"],[Plain "\9492\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9472\9496"]]+ it "when enter is pressed and moves cursor beyond screen bottom" $ do+ -- Cursor is at the begining of text on load.+ testEditor "" (mkKeys 8 Return) (ReferenceScreenState expected_8 (ScreenPos 0 8, Bar))++ describe "Highlighting" $ do+ it "test 1" $ do+ tokenStack <- tokenize "for i = 1 to 10"+ let+ unwrap' (Token tr _ _) = tr+ unwrap :: ([(Text, Maybe Token)], [Token]) -> ([(Text, Maybe TokenRaw)], [TokenRaw])+ unwrap (lst1, tokenlst) = ((\(a, b) -> (a, unwrap' <$> b)) <$> lst1, unwrap' <$> tokenlst)+ (unwrap $ pairWithTokens tokenStack 0 "for i = 1 to 10") `shouldBe` ([("for",Just $ TkKeyword KwFor),(" ",Just $ TkWhitespace (Space 1)),("i",Just $ TkIdentifier (Identifier {unIdentifer = "i"})),(" ",Just $ TkWhitespace (Space 1)),("=",Just $ TkKeyword KwAssignment),(" ",Just $ TkWhitespace (Space 1)),("1",Just $ TkLiteral (LitNumber 1)),(" ",Just $ TkWhitespace (Space 1)),("to",Just $ TkKeyword KwTo),(" ",Just $ TkWhitespace (Space 1)),("10",Just $ TkLiteral (LitNumber 10))],[])+ pure ()++ describe "Token pairing" $ do+ it "Should pair single token" $ do+ genericPairWithTokens stOffsetEnd stLoc 0 "Something" [mkSimpleToken "Something" 0] `shouldBe` ([("Something", Just $ mkSimpleToken "Something" 0)], [])+ it "Should pair single partial start" $ do+ genericPairWithTokens stOffsetEnd stLoc 0 "Somet" [mkSimpleToken "Something" 0] `shouldBe` ([("Somet", Just $ mkSimpleToken "Something" 0)], [mkSimpleToken "Something" 0])+ it "Should pair single partial end" $ do+ genericPairWithTokens stOffsetEnd stLoc 5 "hing" [mkSimpleToken "Something" 0] `shouldBe` ([("hing", Just $ mkSimpleToken "Something" 0)], [])+ it "Should pair single partial end incomplete" $ do+ genericPairWithTokens stOffsetEnd stLoc 5 "hin" [mkSimpleToken "Something" 0] `shouldBe` ([("hin", Just $ mkSimpleToken "Something" 0)], [mkSimpleToken "Something" 0])++ describe "Editor cursor positioning" $ do+ it "test1" $ do+ (fst <$> offsetToScreenPos 5 [5,5] 9) `shouldBe` (Just $ ScreenPos 3 1)+ it "test2" $ do+ (fst <$> offsetToScreenPos 5 [5,3] 5) `shouldBe` (Just $ ScreenPos 5 0)+ it "test2.1" $ do+ (fst <$> offsetToScreenPos 5 [5,3] 6) `shouldBe` (Just $ ScreenPos 0 1)+ it "test3" $ do+ (fst <$> offsetToScreenPos 5 [5,3] 0) `shouldBe` (Just $ ScreenPos 0 0)+ it "test5" $ do+ (fst <$> offsetToScreenPos 5 [10,5] 9) `shouldBe` (Just $ ScreenPos 4 1)+ it "test5.1" $ do+ (fst <$> offsetToScreenPos 5 [10,5] 10) `shouldBe` (Just $ ScreenPos 5 1)+ it "test6" $ do+ (fst <$> offsetToScreenPos 5 [10,5] 5) `shouldBe` (Just $ ScreenPos 0 1)+ it "test7" $ do+ (fst <$> offsetToScreenPos 5 [8,5] 7) `shouldBe` (Just $ ScreenPos 2 1)+ it "test8" $ do+ (fst <$> offsetToScreenPos 5 [5,3,5] 7) `shouldBe` (Just $ ScreenPos 1 1)+ it "test9" $ do+ (fst <$> offsetToScreenPos 5 [5,3,0,5] 10) `shouldBe` (Just $ ScreenPos 0 2)+ it "test10" $ do+ (fst <$> offsetToScreenPos 5 [0,5,3] 1) `shouldBe` (Just $ ScreenPos 0 1)++ describe "Editor reverse cursor positioning" $ do+ it "test1" $ do+ (screenPosToOffset [2,5] 5 (ScreenPos 5 0)) `shouldBe` (Just (2, 1, ScreenPos 2 0))++mkSimpleToken :: Text -> Int -> SimpleToken+mkSimpleToken x offset = NormalToken x (Location 0 0 offset) (offset + T.length x - 1)++data SimpleToken+ = NormalToken { stContent :: Text, stLoc :: Location, stOffsetEnd :: Int }+ deriving (Show, Eq)
+ test/UI/WidgetSpec.hs view
@@ -0,0 +1,17 @@+module UI.WidgetSpec where++import qualified Data.Text as T+import Test.Hspec++import "spade" Common+import Test.Hspec.Hedgehog+import Test.Common++spec :: Spec+spec =+ modifyMaxSuccess (const 10) $ describe "StyledText insertion behavior" $+ it "insertion works as expected" $ hedgehog $ do+ e <- forAll (list (linear 1 100) (getGen @StyledText))+ let i = Plain (T.replicate (stTotalLength e - 5) " ")+ let inserted = stInsert e 0 i+ (stTotalLength e === stTotalLength inserted)