From 99ee96a7c2eb8bd44e8b2bc25d2dd3433dc4bb12 Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 16 Nov 2022 15:29:17 +0100 Subject: [PATCH 01/75] Statement data class --- src/Statement.hs | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 src/Statement.hs diff --git a/src/Statement.hs b/src/Statement.hs new file mode 100644 index 0000000..93e8c5e --- /dev/null +++ b/src/Statement.hs @@ -0,0 +1,32 @@ +module Statement(Operations, Expression, FunctionCallT, ApplicationT, IfT, Statement) where + + data Operations = Addition + | Subtraction + | Multiplication + | Division + | Modulo + | Equals + | NotEquals + | Greater + | GreaterOrEquals + | Less + | LessOrEquals + | LazyAnd + | LazyOr deriving (Eq, Show) + + + data Expression = FunctionCall FunctionCallT + | VariableName String + | Const Int + | Application ApplicationT + + data FunctionCallT = FunctionCallT { functionName :: String, arguments :: [Expression] } + data ApplicationT = ApplicationT { leftOperand :: Expression, op :: Operations, rightOperand :: Expression } + data IfT = IfT { condition :: Expression, statementTrue :: Statement, statementFalse :: Statement} + + data Statement = Let String Expression + | FunctionCallStatement FunctionCallT + | Write Expression + | Read Expression + | While Expression Statement + | If IfT From 67762a5bf74d3b0310a3a996adac26345bad96d9 Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 16 Nov 2022 18:54:44 +0100 Subject: [PATCH 02/75] First attempt of parsers --- L-static-analyzer.cabal | 19 +++++++++++++++++-- package.yaml | 12 +++++++++++- src/Grammar.hs | 23 +++++++++++++++++++++++ src/Statement.hs | 12 ++++++------ test/Spec.hs | 2 -- 5 files changed, 57 insertions(+), 11 deletions(-) create mode 100644 src/Grammar.hs delete mode 100644 test/Spec.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 2e805bf..a331073 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -25,7 +25,9 @@ source-repository head library exposed-modules: + Grammar Lib + Statement other-modules: Paths_L_static_analyzer hs-source-dirs: @@ -33,6 +35,7 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , megaparsec default-language: Haskell2010 executable L-static-analyzer-exe @@ -45,17 +48,29 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , megaparsec default-language: Haskell2010 test-suite L-static-analyzer-test type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Test.hs other-modules: + Test.Parsers Paths_L_static_analyzer hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - L-static-analyzer + HUnit + , HUnit-approx + , L-static-analyzer , base >=4.7 && <5 + , hedgehog + , hspec + , hspec-megaparsec + , megaparsec + , tasty + , tasty-discover + , tasty-hedgehog + , tasty-hunit default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 0da5b74..b64e715 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- megaparsec ghc-options: - -Wall @@ -49,11 +50,20 @@ executables: tests: L-static-analyzer-test: - main: Spec.hs + main: Test.hs source-dirs: test ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N dependencies: + - hedgehog + - HUnit + - HUnit-approx + - hspec + - hspec-megaparsec + - tasty + - tasty-hedgehog + - tasty-hunit + - tasty-discover - L-static-analyzer diff --git a/src/Grammar.hs b/src/Grammar.hs new file mode 100644 index 0000000..8eb5ba9 --- /dev/null +++ b/src/Grammar.hs @@ -0,0 +1,23 @@ +module Grammar where +import Data.Void +import Control.Monad +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Statement (Expression(..)) + +type Parser = Parsec Void String + +sc :: Parser () +sc = L.space (void spaceChar) empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + + +pInteger :: Parser Expression +pInteger = Const <$> lexeme L.decimal + +pVarName :: Parser Expression +pVarName = VariableName <$> lexeme ((:) <$> letterChar <*> many alphaNumChar "Variable") \ No newline at end of file diff --git a/src/Statement.hs b/src/Statement.hs index 93e8c5e..cca9864 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -1,4 +1,4 @@ -module Statement(Operations, Expression, FunctionCallT, ApplicationT, IfT, Statement) where +module Statement where data Operations = Addition | Subtraction @@ -18,15 +18,15 @@ module Statement(Operations, Expression, FunctionCallT, ApplicationT, IfT, State data Expression = FunctionCall FunctionCallT | VariableName String | Const Int - | Application ApplicationT + | Application ApplicationT deriving (Show, Eq) - data FunctionCallT = FunctionCallT { functionName :: String, arguments :: [Expression] } - data ApplicationT = ApplicationT { leftOperand :: Expression, op :: Operations, rightOperand :: Expression } - data IfT = IfT { condition :: Expression, statementTrue :: Statement, statementFalse :: Statement} + data FunctionCallT = FunctionCallT { functionName :: String, arguments :: [Expression] } deriving (Show, Eq) + data ApplicationT = ApplicationT { leftOperand :: Expression, op :: Operations, rightOperand :: Expression } deriving (Show, Eq) + data IfT = IfT { condition :: Expression, statementTrue :: Statement, statementFalse :: Statement} deriving (Show, Eq) data Statement = Let String Expression | FunctionCallStatement FunctionCallT | Write Expression | Read Expression | While Expression Statement - | If IfT + | If IfT deriving (Show, Eq) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" From d3cb3d13e228ddadf9c8df3a5b758b6e71e5aff7 Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 16 Nov 2022 18:56:22 +0100 Subject: [PATCH 03/75] Tests --- test/Test.hs | 1 + test/Test/Parsers.hs | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 test/Test.hs create mode 100644 test/Test/Parsers.hs diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 index 0000000..d7a0a67 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} \ No newline at end of file diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs new file mode 100644 index 0000000..f2bf7d4 --- /dev/null +++ b/test/Test/Parsers.hs @@ -0,0 +1,40 @@ +module Test.Parsers where + +import Text.Megaparsec +import Grammar +import Statement + +import Test.HUnit + +parseSuccessful :: Eq a => Parser a -> String -> a -> Bool +parseSuccessful parser line result = case parse parser "" line of + Left _ -> False + Right a -> a == result + +parseFailed :: Parser a -> String -> Bool +parseFailed parser line = case parse parser "" line of + Left _ -> True + Right _ -> False + + +unit_parser_const :: IO () +unit_parser_const = do + let succConst = parseSuccessful pInteger + let failConst = parseFailed pInteger + + assertBool "const parser failed" $ succConst "1" (Const 1) + assertBool "const parser failed" $ succConst "1.23456" (Const 1) + assertBool "const parser failed" $ succConst "1234567" (Const 1234567) + assertBool "const parser failed" $ failConst "ahahahahh1234" + +unit_parser_var_name :: IO () +unit_parser_var_name = do + let succVar = parseSuccessful pVarName + let failVar = parseFailed pVarName + + assertBool "var parser failed" $ failVar "1234abc" + assertBool "var parser failed" $ failVar "" + assertBool "var parser failed" $ succVar "abcd" (VariableName "abcd") + assertBool "var parser failed" $ succVar "a1234" (VariableName "a1234") + + From c0961f6032ea07b76a9ced7fc9c1ed4e97023edc Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 17 Nov 2022 16:36:29 +0100 Subject: [PATCH 04/75] Parser is ready --- src/Grammar.hs | 86 ++++++++++++++++++++++++++++++++++++++++---- src/Statement.hs | 58 ++++++++++++++++-------------- test/Test/Parsers.hs | 6 ++-- 3 files changed, 115 insertions(+), 35 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index 8eb5ba9..396fde5 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -1,12 +1,12 @@ module Grammar where -import Data.Void + import Control.Monad +import Data.Void +import Statement (Expression (..), Statement (..), reservedKeywords) import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Statement (Expression(..)) - type Parser = Parsec Void String sc :: Parser () @@ -15,9 +15,83 @@ sc = L.space (void spaceChar) empty empty lexeme :: Parser a -> Parser a lexeme = L.lexeme sc +symbol :: String -> Parser String +symbol = L.symbol sc -pInteger :: Parser Expression -pInteger = Const <$> lexeme L.decimal +pConst :: Parser Expression +pConst = Const <$> lexeme L.decimal "const value" + +pName :: Parser String +pName = (lexeme . try) (p >>= check) + where + p = (:) <$> letterChar <*> many alphaNumChar "Variable" + check x + | x `elem` reservedKeywords = fail $ "keyword " ++ show x ++ " cannot be an identifier" + | otherwise = return x pVarName :: Parser Expression -pVarName = VariableName <$> lexeme ((:) <$> letterChar <*> many alphaNumChar "Variable") \ No newline at end of file +pVarName = VariableName <$> pName + +pFunctionCall :: Parser Expression +pFunctionCall = do + FunctionCall <$> (lexeme pName "Function name") <*> (arguments "arguments") + where + arguments :: Parser [Expression] + arguments = (:) <$> pExpression <*> many pExpression + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +pExpression :: Parser Expression +pExpression = + choice + [ parens pExpression, + try pFunctionCall, + pVarName, -- TODO: "a " should raise function without arguments error, not var parsing error + pConst + ] + +letVariable :: Parser Statement +letVariable = + Let <$> (lexeme pName "Variable name") <*> (symbol ":=" *> pExpression) "Variable let" + +write :: Parser Statement +write = do + Write <$> (symbol "write" *> pExpression) "while statement" + +readVariable :: Parser Statement +readVariable = do + Read <$> (symbol "read" *> pName "Read statement") + +while :: Parser Statement +while = + While + <$> (between (symbol "while") (symbol "do") pExpression "While condition") + <*> (statement "While statement") + +ifThenElse :: Parser Statement +ifThenElse = + If + <$> (symbol "if" *> pExpression "If condition") + <*> (symbol "then" *> statement "True statement") + <*> (symbol "else" *> statement "False Statement") + +functionCallStatement :: Parser Statement +functionCallStatement = + FunctionCallStatement + <$> (pName "function name") + <*> (arguments "arguments") + where + arguments :: Parser [Expression] + arguments = (:) <$> pExpression <*> many pExpression + +statement :: Parser Statement +statement = + choice + [ write, + readVariable, + while, + ifThenElse, + try functionCallStatement, + letVariable + ] diff --git a/src/Statement.hs b/src/Statement.hs index cca9864..21f1105 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -1,32 +1,38 @@ module Statement where - data Operations = Addition - | Subtraction - | Multiplication - | Division - | Modulo - | Equals - | NotEquals - | Greater - | GreaterOrEquals - | Less - | LessOrEquals - | LazyAnd - | LazyOr deriving (Eq, Show) +data Operations + = Addition + | Subtraction + | Multiplication + | Division + | Modulo + | Equals + | NotEquals + | Greater + | GreaterOrEquals + | Less + | LessOrEquals + | LazyAnd + | LazyOr + deriving (Eq, Show) +data Expression + = FunctionCall String [Expression] + | VariableName String + | Const Int + | Application ApplicationT + deriving (Show, Eq) - data Expression = FunctionCall FunctionCallT - | VariableName String - | Const Int - | Application ApplicationT deriving (Show, Eq) +data ApplicationT = ApplicationT {leftOperand :: Expression, op :: Operations, rightOperand :: Expression} deriving (Show, Eq) - data FunctionCallT = FunctionCallT { functionName :: String, arguments :: [Expression] } deriving (Show, Eq) - data ApplicationT = ApplicationT { leftOperand :: Expression, op :: Operations, rightOperand :: Expression } deriving (Show, Eq) - data IfT = IfT { condition :: Expression, statementTrue :: Statement, statementFalse :: Statement} deriving (Show, Eq) +data Statement + = Let String Expression + | FunctionCallStatement String [Expression] + | Write Expression + | Read String + | While Expression Statement + | If Expression Statement Statement + deriving (Show, Eq) - data Statement = Let String Expression - | FunctionCallStatement FunctionCallT - | Write Expression - | Read Expression - | While Expression Statement - | If IfT deriving (Show, Eq) +reservedKeywords :: [String] +reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index f2bf7d4..22133bf 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -19,9 +19,9 @@ parseFailed parser line = case parse parser "" line of unit_parser_const :: IO () unit_parser_const = do - let succConst = parseSuccessful pInteger - let failConst = parseFailed pInteger - + let succConst = parseSuccessful pConst + let failConst = parseFailed pConst + assertBool "const parser failed" $ succConst "1" (Const 1) assertBool "const parser failed" $ succConst "1.23456" (Const 1) assertBool "const parser failed" $ succConst "1234567" (Const 1234567) From f8e3876f283f9fe48f1f55c99f6f9c00e47bf439 Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 17 Nov 2022 21:26:30 +0100 Subject: [PATCH 05/75] It works, but test should be written --- L-static-analyzer.cabal | 3 +++ package.yaml | 1 + src/Grammar.hs | 56 ++++++++++++++++++++++++++++++++--------- src/Statement.hs | 30 +++++++++++----------- test/Test/Parsers.hs | 31 ++++++++++++++++++++--- 5 files changed, 90 insertions(+), 31 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index a331073..4d1835f 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -36,6 +36,7 @@ library build-depends: base >=4.7 && <5 , megaparsec + , parser-combinators default-language: Haskell2010 executable L-static-analyzer-exe @@ -49,6 +50,7 @@ executable L-static-analyzer-exe L-static-analyzer , base >=4.7 && <5 , megaparsec + , parser-combinators default-language: Haskell2010 test-suite L-static-analyzer-test @@ -69,6 +71,7 @@ test-suite L-static-analyzer-test , hspec , hspec-megaparsec , megaparsec + , parser-combinators , tasty , tasty-discover , tasty-hedgehog diff --git a/package.yaml b/package.yaml index b64e715..05f959d 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - megaparsec +- parser-combinators ghc-options: - -Wall diff --git a/src/Grammar.hs b/src/Grammar.hs index 396fde5..d371c54 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -1,8 +1,9 @@ module Grammar where import Control.Monad +import Control.Monad.Combinators.Expr import Data.Void -import Statement (Expression (..), Statement (..), reservedKeywords) +import Statement (Expression (..), Operations (..), Statement (..), reservedKeywords) import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L @@ -34,30 +35,61 @@ pVarName = VariableName <$> pName pFunctionCall :: Parser Expression pFunctionCall = do - FunctionCall <$> (lexeme pName "Function name") <*> (arguments "arguments") + FunctionCall <$> (lexeme pName "Function name") <*> (arguments "arguments") where arguments :: Parser [Expression] - arguments = (:) <$> pExpression <*> many pExpression + arguments = (:) <$> expression <*> many expression parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") -pExpression :: Parser Expression -pExpression = +expressionTerm :: Parser Expression +expressionTerm = choice - [ parens pExpression, + [ parens expression, try pFunctionCall, - pVarName, -- TODO: "a " should raise function without arguments error, not var parsing error + pVarName, pConst ] +binary :: String -> (Expression -> Expression -> Expression) -> Operator Parser Expression +binary name f = InfixL (f <$ symbol name) + +compose :: (Expression -> Expression -> Operations) -> Expression -> Expression -> Expression +compose f a b = Application $ f a b + +expressionOperationsTable :: [[Operator Parser Expression]] +expressionOperationsTable = + [ [ binary "*" $ compose Multiplication, + binary "/" $ compose Division, + binary "%" $ compose Modulo + ], + [ binary "+" $ compose Addition, + binary "-" $ compose Subtraction + ], + [ binary "==" $ compose Equals, + binary "!=" $ compose NotEquals, + binary "<" $ compose Less, + binary "<=" $ compose LessOrEquals, + binary ">=" $ compose GreaterOrEquals, + binary ">" $ compose Greater + ], + [ binary "&&" $ compose LazyAnd + ], + [ binary "||" $ compose LazyOr + ] + ] + +expression :: Parser Expression +expression = makeExprParser expressionTerm expressionOperationsTable + letVariable :: Parser Statement letVariable = - Let <$> (lexeme pName "Variable name") <*> (symbol ":=" *> pExpression) "Variable let" + Let <$> (lexeme pName "Variable name") <*> (symbol ":=" *> expression) "Variable let" write :: Parser Statement write = do - Write <$> (symbol "write" *> pExpression) "while statement" + Write <$> (symbol "write" *> expression) "while statement" readVariable :: Parser Statement readVariable = do @@ -66,13 +98,13 @@ readVariable = do while :: Parser Statement while = While - <$> (between (symbol "while") (symbol "do") pExpression "While condition") + <$> (between (symbol "while") (symbol "do") expression "While condition") <*> (statement "While statement") ifThenElse :: Parser Statement ifThenElse = If - <$> (symbol "if" *> pExpression "If condition") + <$> (symbol "if" *> expression "If condition") <*> (symbol "then" *> statement "True statement") <*> (symbol "else" *> statement "False Statement") @@ -83,7 +115,7 @@ functionCallStatement = <*> (arguments "arguments") where arguments :: Parser [Expression] - arguments = (:) <$> pExpression <*> many pExpression + arguments = (:) <$> expression <*> many expression statement :: Parser Statement statement = diff --git a/src/Statement.hs b/src/Statement.hs index 21f1105..157a26d 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -1,30 +1,28 @@ module Statement where data Operations - = Addition - | Subtraction - | Multiplication - | Division - | Modulo - | Equals - | NotEquals - | Greater - | GreaterOrEquals - | Less - | LessOrEquals - | LazyAnd - | LazyOr + = Addition Expression Expression + | Subtraction Expression Expression + | Multiplication Expression Expression + | Division Expression Expression + | Modulo Expression Expression + | Equals Expression Expression + | NotEquals Expression Expression + | Greater Expression Expression + | GreaterOrEquals Expression Expression + | Less Expression Expression + | LessOrEquals Expression Expression + | LazyAnd Expression Expression + | LazyOr Expression Expression deriving (Eq, Show) data Expression = FunctionCall String [Expression] | VariableName String | Const Int - | Application ApplicationT + | Application Operations deriving (Show, Eq) -data ApplicationT = ApplicationT {leftOperand :: Expression, op :: Operations, rightOperand :: Expression} deriving (Show, Eq) - data Statement = Let String Expression | FunctionCallStatement String [Expression] diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 22133bf..eb2c063 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -1,10 +1,9 @@ module Test.Parsers where -import Text.Megaparsec import Grammar import Statement - import Test.HUnit +import Text.Megaparsec parseSuccessful :: Eq a => Parser a -> String -> a -> Bool parseSuccessful parser line result = case parse parser "" line of @@ -16,7 +15,6 @@ parseFailed parser line = case parse parser "" line of Left _ -> True Right _ -> False - unit_parser_const :: IO () unit_parser_const = do let succConst = parseSuccessful pConst @@ -37,4 +35,31 @@ unit_parser_var_name = do assertBool "var parser failed" $ succVar "abcd" (VariableName "abcd") assertBool "var parser failed" $ succVar "a1234" (VariableName "a1234") + assertBool "bad keywords are banned" $ failVar "while" + assertBool "bad keywords are banned" $ failVar "do" + assertBool "bad keywords are banned" $ failVar "if" + assertBool "bad keywords are banned" $ failVar "then" + assertBool "bad keywords are banned" $ failVar "else" + +unit_parser_expr :: IO () +unit_parser_expr = do + let succExpr = parseSuccessful expression + let failExpr = parseFailed expression + assertBool "simple expression" $ succExpr "1" (Const 1) + assertBool "simple with parens" $ succExpr "(1)" (Const 1) + assertBool "operations works fine" $ succExpr "1 + 3" (Application $ Addition (Const 1) (Const 3)) + assertBool "precedence works fine" $ + succExpr + "1 * 2 + 3" + ( Application $ + Addition + ( Application $ + Multiplication + (Const 1) + (Const 2) + ) + (Const 3) + ) + + From 0de0bdf261426034a08f53496a39cbafa396cb76 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 18 Nov 2022 09:59:53 +0100 Subject: [PATCH 06/75] Refactor --- src/Grammar.hs | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index d371c54..af0335f 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -19,23 +19,23 @@ lexeme = L.lexeme sc symbol :: String -> Parser String symbol = L.symbol sc -pConst :: Parser Expression -pConst = Const <$> lexeme L.decimal "const value" +constValue :: Parser Expression +constValue = Const <$> lexeme L.decimal "const value" -pName :: Parser String -pName = (lexeme . try) (p >>= check) +name :: Parser String +name = (lexeme . try) (p >>= check) where p = (:) <$> letterChar <*> many alphaNumChar "Variable" check x | x `elem` reservedKeywords = fail $ "keyword " ++ show x ++ " cannot be an identifier" | otherwise = return x -pVarName :: Parser Expression -pVarName = VariableName <$> pName +varName :: Parser Expression +varName = VariableName <$> name -pFunctionCall :: Parser Expression -pFunctionCall = do - FunctionCall <$> (lexeme pName "Function name") <*> (arguments "arguments") +funCall :: Parser Expression +funCall = do + FunctionCall <$> (lexeme name "Function name") <*> (arguments "arguments") where arguments :: Parser [Expression] arguments = (:) <$> expression <*> many expression @@ -47,17 +47,11 @@ expressionTerm :: Parser Expression expressionTerm = choice [ parens expression, - try pFunctionCall, - pVarName, - pConst + try funCall, + varName, + constValue ] -binary :: String -> (Expression -> Expression -> Expression) -> Operator Parser Expression -binary name f = InfixL (f <$ symbol name) - -compose :: (Expression -> Expression -> Operations) -> Expression -> Expression -> Expression -compose f a b = Application $ f a b - expressionOperationsTable :: [[Operator Parser Expression]] expressionOperationsTable = [ [ binary "*" $ compose Multiplication, @@ -79,13 +73,19 @@ expressionOperationsTable = [ binary "||" $ compose LazyOr ] ] + where + binary :: String -> (Expression -> Expression -> Expression) -> Operator Parser Expression + binary name f = InfixL (f <$ symbol name) + + compose :: (Expression -> Expression -> Operations) -> Expression -> Expression -> Expression + compose f a b = Application $ f a b expression :: Parser Expression expression = makeExprParser expressionTerm expressionOperationsTable letVariable :: Parser Statement letVariable = - Let <$> (lexeme pName "Variable name") <*> (symbol ":=" *> expression) "Variable let" + Let <$> (lexeme name "Variable name") <*> (symbol ":=" *> expression) "Variable let" write :: Parser Statement write = do @@ -93,7 +93,7 @@ write = do readVariable :: Parser Statement readVariable = do - Read <$> (symbol "read" *> pName "Read statement") + Read <$> (symbol "read" *> name "Read statement") while :: Parser Statement while = @@ -108,10 +108,10 @@ ifThenElse = <*> (symbol "then" *> statement "True statement") <*> (symbol "else" *> statement "False Statement") -functionCallStatement :: Parser Statement -functionCallStatement = +funCallStatement :: Parser Statement +funCallStatement = FunctionCallStatement - <$> (pName "function name") + <$> (name "function name") <*> (arguments "arguments") where arguments :: Parser [Expression] @@ -124,6 +124,6 @@ statement = readVariable, while, ifThenElse, - try functionCallStatement, + try funCallStatement, letVariable ] From 23942c0676aea9fcda8ddba1f07be751d724e616 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 18 Nov 2022 11:23:38 +0100 Subject: [PATCH 07/75] Tests --- src/Grammar.hs | 2 +- test/Test/Parsers.hs | 135 ++++++++++++++++++++++++++++++++++++++----- 2 files changed, 121 insertions(+), 16 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index af0335f..adcfa57 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -26,7 +26,7 @@ name :: Parser String name = (lexeme . try) (p >>= check) where p = (:) <$> letterChar <*> many alphaNumChar "Variable" - check x + check x -- TODO: check for function names are required due to `f argument1 argument2 1` issue | x `elem` reservedKeywords = fail $ "keyword " ++ show x ++ " cannot be an identifier" | otherwise = return x diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index eb2c063..b92405a 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -6,29 +6,29 @@ import Test.HUnit import Text.Megaparsec parseSuccessful :: Eq a => Parser a -> String -> a -> Bool -parseSuccessful parser line result = case parse parser "" line of +parseSuccessful parser line result = case parse (parser <* eof) "" line of Left _ -> False Right a -> a == result parseFailed :: Parser a -> String -> Bool -parseFailed parser line = case parse parser "" line of +parseFailed parser line = case parse (parser <* eof) "" line of Left _ -> True Right _ -> False -unit_parser_const :: IO () -unit_parser_const = do - let succConst = parseSuccessful pConst - let failConst = parseFailed pConst +unit_const :: IO () +unit_const = do + let succConst = parseSuccessful constValue + let failConst = parseFailed constValue assertBool "const parser failed" $ succConst "1" (Const 1) - assertBool "const parser failed" $ succConst "1.23456" (Const 1) + assertBool "const parser failed" $ failConst "1.23456" assertBool "const parser failed" $ succConst "1234567" (Const 1234567) assertBool "const parser failed" $ failConst "ahahahahh1234" -unit_parser_var_name :: IO () -unit_parser_var_name = do - let succVar = parseSuccessful pVarName - let failVar = parseFailed pVarName +unit_var_name :: IO () +unit_var_name = do + let succVar = parseSuccessful varName + let failVar = parseFailed varName assertBool "var parser failed" $ failVar "1234abc" assertBool "var parser failed" $ failVar "" @@ -41,8 +41,8 @@ unit_parser_var_name = do assertBool "bad keywords are banned" $ failVar "then" assertBool "bad keywords are banned" $ failVar "else" -unit_parser_expr :: IO () -unit_parser_expr = do +unit_expr :: IO () +unit_expr = do let succExpr = parseSuccessful expression let failExpr = parseFailed expression @@ -61,5 +61,110 @@ unit_parser_expr = do ) (Const 3) ) - - + + assertBool "fails on unary" $ failExpr "+1" + assertBool "fails on bad expr" $ failExpr "1+2++-" + +unit_let :: IO () +unit_let = do + let success = parseSuccessful letVariable + let fail = parseFailed letVariable + + assertBool "to const" $ success "x := 1" (Let "x" (Const 1)) + assertBool "reassign" $ success "x := x" (Let "x" (VariableName "x")) + assertBool "compicated expression" $ + success + "x := y % 4 + 2 * 3" + ( Let + "x" + ( Application $ + Addition + ( Application $ + Modulo + (VariableName "y") + (Const 4) + ) + ( Application $ + Multiplication + (Const 2) + (Const 3) + ) + ) + ) + + assertBool "assign statement" $ fail "x := while 1 do 2" + +-- TODO: uncomment this (see Grammar.hs for details) +-- assertBool "assign function call" $ +-- success +-- "loooooong := function first second third 1 (2 + 3)" +-- ( Let +-- "loooooong" +-- ( FunctionCall +-- "function" +-- [ VariableName "first" +-- , VariableName "second" +-- , VariableName "third" +-- , Const 1 +-- , Application $ Addition (Const 2) (Const 3) +-- ] +-- ) +-- ) + +unit_while :: IO () +unit_while = do + let success = parseSuccessful while + let fail = parseFailed while + + assertBool "simple while" $ success "while 1 do x := x" $ While (Const 1) (Let "x" (VariableName "x")) + assertBool "complicated expression" $ + success "while 1 + 2 do x := x" $ + While + (Application $ Addition (Const 1) (Const 2)) + (Let "x" (VariableName "x")) + + assertBool "function call" $ + success "while f 1 do x := x" $ + While + (FunctionCall "f" [Const 1]) + (Let "x" (VariableName "x")) + + assertBool "just while fails" $ fail "while" + assertBool "just while-do failes" $ fail "while do" + assertBool "without statement fail" $ fail "while 1 do" + assertBool "without condition fail" $ fail "while do x := x" + +unit_if :: IO () +unit_if = do + let success = parseSuccessful ifThenElse + let fail = parseFailed ifThenElse + + assertBool "simple if" $ + success "if 1 then a 1 else a 2" $ + If + (Const 1) + (FunctionCallStatement "a" [Const 1]) + (FunctionCallStatement "a" [Const 2]) + + assertBool "if fails with statement in condition" $ fail "if x := 1 then a 1 else a 2" + +unit_statement :: IO () +unit_statement = do + let success = parseSuccessful statement + let fail = parseFailed statement + + assertBool "function call" $ success "f 1 2 3" $ FunctionCallStatement "f" [Const 1, Const 2, Const 3] + assertBool "read variable" $ success "read x" $ Read "x" + assertBool "read expression fails" $ fail "read x + 2" + assertBool "write variable" $ success "write x" $ Write (VariableName "x") + assertBool "write complex expression" $ + success "write x + 2 * 3" $ + Write $ + Application $ + Addition + (VariableName "x") + ( Application $ + Multiplication + (Const 2) + (Const 3) + ) From c9bf07cebb14712ea248113031847a154f55a2af Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 18 Nov 2022 12:23:17 +0100 Subject: [PATCH 08/75] toy write --- app/Main.hs | 9 +++++++-- package.yaml | 3 +++ src/Context.hs | 26 ++++++++++++++++++++++++++ src/Error.hs | 7 +++++++ src/Evaluate.hs | 11 +++++++++++ src/Execute.hs | 14 ++++++++++++++ src/Statement.hs | 36 ++++++++++++++++++++++++++++++++++++ 7 files changed, 104 insertions(+), 2 deletions(-) create mode 100644 src/Context.hs create mode 100644 src/Error.hs create mode 100644 src/Evaluate.hs create mode 100644 src/Execute.hs create mode 100644 src/Statement.hs diff --git a/app/Main.hs b/app/Main.hs index 4c6b30f..50a9cce 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,11 @@ module Main (main) where -import Lib +import Statement(Statement(Write), Expression(Const)) +import Execute (executeStatement) +import GHC.Base (IO(IO)) +import Context ( Context(Context, io), FunContext(FunContext), emptyContext) main :: IO () -main = someFunc +main = do + let st = Write (Const 1) + io $ executeStatement emptyContext st diff --git a/package.yaml b/package.yaml index 0da5b74..0e5acaf 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,8 @@ ghc-options: library: source-dirs: src + dependencies: + - containers executables: L-static-analyzer-exe: @@ -57,3 +59,4 @@ tests: - -with-rtsopts=-N dependencies: - L-static-analyzer + - HUnit diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 index 0000000..c629b4d --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,26 @@ +module Context where +import Error ( RuntimeError(VarNameError) ) +import qualified Data.Map as Map + +data FunContext = FunContext deriving (Show, Eq) + +data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, Eq) + +getVar :: VarContext -> String -> Either RuntimeError Int +getVar cxt var = let x = Map.lookup var (context cxt) in + case x of + Nothing -> Left (VarNameError var) + Just res -> Right res + +emptyVarContext :: VarContext +emptyVarContext = VarContext { context = Map.empty } + +data Context = Context { funs :: FunContext, vars :: VarContext, io :: IO (), error :: Maybe RuntimeError } + +emptyContext :: Context +emptyContext = Context { + funs = FunContext, + vars = emptyVarContext, + io = pure (), + Context.error = Nothing +} diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 0000000..c2fc2dd --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,7 @@ +module Error where +import Statement(Expression) + +data RuntimeError = EvalError Expression + | VarNameError String + | UnsupportedError + deriving (Show, Eq) diff --git a/src/Evaluate.hs b/src/Evaluate.hs new file mode 100644 index 0000000..b7ba266 --- /dev/null +++ b/src/Evaluate.hs @@ -0,0 +1,11 @@ +module Evaluate where +import Statement (Expression (Const, FunctionCall, VariableName, Application)) +import Context ( Context(vars), getVar ) +import Error ( RuntimeError(UnsupportedError) ) + + +evaluate :: Context -> Expression -> (Context, Either RuntimeError Int) +evaluate cxt (Const x) = (cxt, Right x) +evaluate cxt (VariableName var) = (cxt, getVar (vars cxt) var) +evaluate cxt (FunctionCall _ _) = (cxt, Left UnsupportedError) -- TODO +evaluate cxt (Application _) = (cxt, Left UnsupportedError) -- TODO diff --git a/src/Execute.hs b/src/Execute.hs new file mode 100644 index 0000000..cc1b12e --- /dev/null +++ b/src/Execute.hs @@ -0,0 +1,14 @@ +module Execute where +import Statement (Statement(Write)) +import Context (Context(io, error)) +import Error (RuntimeError(UnsupportedError)) +import Evaluate ( evaluate ) + + +executeStatement :: Context -> Statement -> Context +executeStatement cxt (Write expr) = cxt' { io = io cxt' >> putStrLn unwrap_x } where + (cxt', x) = evaluate cxt expr + unwrap_x = case x of + Left err -> show err + Right res -> show res +executeStatement cxt _ = cxt { Context.error = Just UnsupportedError } \ No newline at end of file diff --git a/src/Statement.hs b/src/Statement.hs new file mode 100644 index 0000000..157a26d --- /dev/null +++ b/src/Statement.hs @@ -0,0 +1,36 @@ +module Statement where + +data Operations + = Addition Expression Expression + | Subtraction Expression Expression + | Multiplication Expression Expression + | Division Expression Expression + | Modulo Expression Expression + | Equals Expression Expression + | NotEquals Expression Expression + | Greater Expression Expression + | GreaterOrEquals Expression Expression + | Less Expression Expression + | LessOrEquals Expression Expression + | LazyAnd Expression Expression + | LazyOr Expression Expression + deriving (Eq, Show) + +data Expression + = FunctionCall String [Expression] + | VariableName String + | Const Int + | Application Operations + deriving (Show, Eq) + +data Statement + = Let String Expression + | FunctionCallStatement String [Expression] + | Write Expression + | Read String + | While Expression Statement + | If Expression Statement Statement + deriving (Show, Eq) + +reservedKeywords :: [String] +reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file From 45eba8fcc49ee97f77e24f7b5b6c194b6d14f9f7 Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 18 Nov 2022 13:10:15 +0100 Subject: [PATCH 09/75] use Context as IO monad --- app/Main.hs | 18 +++++++++++++----- src/Context.hs | 7 +++++-- src/Evaluate.hs | 10 +++++----- src/Execute.hs | 21 ++++++++++++++------- src/Statement.hs | 1 + 5 files changed, 38 insertions(+), 19 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 50a9cce..6ee8c05 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,11 +1,19 @@ module Main (main) where -import Statement(Statement(Write), Expression(Const)) -import Execute (executeStatement) -import GHC.Base (IO(IO)) -import Context ( Context(Context, io), FunContext(FunContext), emptyContext) +import Statement(Statement(Write, Skip), Expression(Const)) +import Execute (execute) +import Context (emptyContext, error) main :: IO () main = do let st = Write (Const 1) - io $ executeStatement emptyContext st + let err = Skip + res <- execute emptyContext [st, st, st] + case Context.error res of + Nothing -> putStrLn "Success!" + Just err -> putStrLn $ "Error: " ++ show err + + res <- execute emptyContext [st, err, st] + case Context.error res of + Nothing -> putStrLn "Success!" + Just err -> putStrLn $ "Error: " ++ show err diff --git a/src/Context.hs b/src/Context.hs index c629b4d..6bcba76 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} module Context where import Error ( RuntimeError(VarNameError) ) import qualified Data.Map as Map @@ -15,12 +16,14 @@ getVar cxt var = let x = Map.lookup var (context cxt) in emptyVarContext :: VarContext emptyVarContext = VarContext { context = Map.empty } -data Context = Context { funs :: FunContext, vars :: VarContext, io :: IO (), error :: Maybe RuntimeError } +data Context = Context { funs :: FunContext, vars :: VarContext, error :: Maybe RuntimeError } emptyContext :: Context emptyContext = Context { funs = FunContext, vars = emptyVarContext, - io = pure (), Context.error = Nothing } + +pattern ErrorContext :: Context +pattern ErrorContext <- Context { Context.error = (Just _) } diff --git a/src/Evaluate.hs b/src/Evaluate.hs index b7ba266..e793ab7 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -4,8 +4,8 @@ import Context ( Context(vars), getVar ) import Error ( RuntimeError(UnsupportedError) ) -evaluate :: Context -> Expression -> (Context, Either RuntimeError Int) -evaluate cxt (Const x) = (cxt, Right x) -evaluate cxt (VariableName var) = (cxt, getVar (vars cxt) var) -evaluate cxt (FunctionCall _ _) = (cxt, Left UnsupportedError) -- TODO -evaluate cxt (Application _) = (cxt, Left UnsupportedError) -- TODO +evaluate :: Context -> Expression -> (IO Context, Either RuntimeError Int) +evaluate cxt (Const x) = (pure cxt, Right x) +evaluate cxt (VariableName var) = (pure cxt, getVar (vars cxt) var) +evaluate cxt (FunctionCall _ _) = (pure cxt, Left UnsupportedError) -- TODO +evaluate cxt (Application _) = (pure cxt, Left UnsupportedError) -- TODO diff --git a/src/Execute.hs b/src/Execute.hs index cc1b12e..c2e8490 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,14 +1,21 @@ +{-# LANGUAGE PatternSynonyms #-} module Execute where import Statement (Statement(Write)) -import Context (Context(io, error)) +import Context ( Context(error), pattern ErrorContext ) import Error (RuntimeError(UnsupportedError)) import Evaluate ( evaluate ) +import Control.Monad (foldM) -executeStatement :: Context -> Statement -> Context -executeStatement cxt (Write expr) = cxt' { io = io cxt' >> putStrLn unwrap_x } where - (cxt', x) = evaluate cxt expr - unwrap_x = case x of +executeStatement :: Context -> Statement -> IO Context +executeStatement c@ErrorContext _ = pure c +executeStatement cxt (Write expr) = do + let (cxt', x) = evaluate cxt expr + putStrLn (case x of Left err -> show err - Right res -> show res -executeStatement cxt _ = cxt { Context.error = Just UnsupportedError } \ No newline at end of file + Right res -> show res) + cxt' +executeStatement cxt _ = pure $ cxt { Context.error = Just UnsupportedError } + +execute :: Context -> [Statement] -> IO Context +execute = foldM executeStatement diff --git a/src/Statement.hs b/src/Statement.hs index 157a26d..d119542 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -30,6 +30,7 @@ data Statement | Read String | While Expression Statement | If Expression Statement Statement + | Skip deriving (Show, Eq) reservedKeywords :: [String] From 3c2519567583427429d2cf41b97d2ae99ef2249c Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 18 Nov 2022 14:23:43 +0100 Subject: [PATCH 10/75] cleanup --- app/Main.hs | 21 +++++++++------------ src/Context.hs | 23 +++++++++++++++++------ src/Error.hs | 1 + src/Evaluate.hs | 13 +++++++------ src/Execute.hs | 32 ++++++++++++++++++++++++-------- 5 files changed, 58 insertions(+), 32 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 6ee8c05..35485ec 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,19 +1,16 @@ module Main (main) where -import Statement(Statement(Write, Skip), Expression(Const)) -import Execute (execute) -import Context (emptyContext, error) +import Statement(Statement(Write, Skip, Read), Expression(Const, VariableName)) +import Execute (run) +import Context (emptyContext) main :: IO () main = do - let st = Write (Const 1) + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") let err = Skip - res <- execute emptyContext [st, st, st] - case Context.error res of - Nothing -> putStrLn "Success!" - Just err -> putStrLn $ "Error: " ++ show err + let readVar = Read "var" - res <- execute emptyContext [st, err, st] - case Context.error res of - Nothing -> putStrLn "Success!" - Just err -> putStrLn $ "Error: " ++ show err + run emptyContext [readVar, writeVar] + run emptyContext [readVar] + run emptyContext [writeVar] diff --git a/src/Context.hs b/src/Context.hs index 6bcba76..c42763e 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -7,12 +7,6 @@ data FunContext = FunContext deriving (Show, Eq) data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, Eq) -getVar :: VarContext -> String -> Either RuntimeError Int -getVar cxt var = let x = Map.lookup var (context cxt) in - case x of - Nothing -> Left (VarNameError var) - Just res -> Right res - emptyVarContext :: VarContext emptyVarContext = VarContext { context = Map.empty } @@ -27,3 +21,20 @@ emptyContext = Context { pattern ErrorContext :: Context pattern ErrorContext <- Context { Context.error = (Just _) } + +getVar :: Context -> String -> (IO Context, Maybe Int) +getVar cxt var = + let mp = context . vars $ cxt in + let x = Map.lookup var mp in + (case x of + Nothing -> setError cxt $ VarNameError var + Just _ -> pure cxt + , x) + +setVar :: Context -> String -> Int -> IO Context +setVar cxt name val = + let mp = context . vars $ cxt in + pure $ cxt { vars = VarContext $ Map.insert name val mp } + +setError :: Context -> RuntimeError -> IO Context +setError cxt err = pure $ cxt { Context.error = Just err } diff --git a/src/Error.hs b/src/Error.hs index c2fc2dd..c0ae991 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -4,4 +4,5 @@ import Statement(Expression) data RuntimeError = EvalError Expression | VarNameError String | UnsupportedError + | InvalidInputError String deriving (Show, Eq) diff --git a/src/Evaluate.hs b/src/Evaluate.hs index e793ab7..3e9f566 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,11 +1,12 @@ module Evaluate where import Statement (Expression (Const, FunctionCall, VariableName, Application)) -import Context ( Context(vars), getVar ) +import Context ( setError, Context(), getVar ) import Error ( RuntimeError(UnsupportedError) ) -evaluate :: Context -> Expression -> (IO Context, Either RuntimeError Int) -evaluate cxt (Const x) = (pure cxt, Right x) -evaluate cxt (VariableName var) = (pure cxt, getVar (vars cxt) var) -evaluate cxt (FunctionCall _ _) = (pure cxt, Left UnsupportedError) -- TODO -evaluate cxt (Application _) = (pure cxt, Left UnsupportedError) -- TODO +evaluate :: Context -> Expression -> (IO Context, Maybe Int) +evaluate cxt (Const x) = (pure cxt, Just x) +evaluate cxt (VariableName var) = getVar cxt var + +evaluate cxt (FunctionCall _ _) = (setError cxt UnsupportedError, Nothing) -- TODO +evaluate cxt (Application _) = (setError cxt UnsupportedError, Nothing) -- TODO diff --git a/src/Execute.hs b/src/Execute.hs index c2e8490..f5e461e 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,21 +1,37 @@ {-# LANGUAGE PatternSynonyms #-} module Execute where -import Statement (Statement(Write)) -import Context ( Context(error), pattern ErrorContext ) -import Error (RuntimeError(UnsupportedError)) +import Statement (Statement(Write, Read)) +import Context ( Context(error), pattern ErrorContext, setVar, setError ) +import Error (RuntimeError(UnsupportedError, InvalidInputError)) import Evaluate ( evaluate ) import Control.Monad (foldM) +import Text.Read (readMaybe) executeStatement :: Context -> Statement -> IO Context executeStatement c@ErrorContext _ = pure c + executeStatement cxt (Write expr) = do let (cxt', x) = evaluate cxt expr - putStrLn (case x of - Left err -> show err - Right res -> show res) - cxt' -executeStatement cxt _ = pure $ cxt { Context.error = Just UnsupportedError } + case x of + Nothing -> cxt' + Just res -> print res >> cxt' + +executeStatement cxt (Read name) = do + line <- getLine + let val = readMaybe line :: Maybe Int + case val of + Nothing -> setError cxt $ InvalidInputError line + Just x -> setVar cxt name x + +executeStatement cxt _ = setError cxt UnsupportedError -- TODO execute :: Context -> [Statement] -> IO Context execute = foldM executeStatement + +run :: Context -> [Statement] -> IO () +run cxt sts = do + res <- execute cxt sts + case Context.error res of + Nothing -> putStrLn "Success!" + Just err -> putStrLn $ "Error: " ++ show err From f393f5015172cc48d9893a0a2df374f399837251 Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 18 Nov 2022 17:31:43 +0100 Subject: [PATCH 11/75] add tests --- app/Main.hs | 5 ++- package.yaml | 4 ++- src/Context.hs | 29 +++++++++++++---- src/Execute.hs | 10 +++--- test/Spec.hs | 2 -- test/Test.hs | 1 + test/Test/Execute.hs | 77 ++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 113 insertions(+), 15 deletions(-) delete mode 100644 test/Spec.hs create mode 100644 test/Test.hs create mode 100644 test/Test/Execute.hs diff --git a/app/Main.hs b/app/Main.hs index 35485ec..7bcfa99 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,9 +8,12 @@ main :: IO () main = do let writeConst = Write (Const 1) let writeVar = Write (VariableName "var") - let err = Skip + let skip = Skip let readVar = Read "var" run emptyContext [readVar, writeVar] run emptyContext [readVar] run emptyContext [writeVar] + run emptyContext [writeConst] + run emptyContext [skip] + diff --git a/package.yaml b/package.yaml index 0e5acaf..85e5a8e 100644 --- a/package.yaml +++ b/package.yaml @@ -51,7 +51,7 @@ executables: tests: L-static-analyzer-test: - main: Spec.hs + main: Test.hs source-dirs: test ghc-options: - -threaded @@ -60,3 +60,5 @@ tests: dependencies: - L-static-analyzer - HUnit + - tasty-hunit + - tasty diff --git a/src/Context.hs b/src/Context.hs index c42763e..e286567 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE InstanceSigs #-} module Context where import Error ( RuntimeError(VarNameError) ) import qualified Data.Map as Map @@ -10,14 +11,30 @@ data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, E emptyVarContext :: VarContext emptyVarContext = VarContext { context = Map.empty } -data Context = Context { funs :: FunContext, vars :: VarContext, error :: Maybe RuntimeError } +data Context = Context + { funs :: FunContext + , vars :: VarContext + , error :: Maybe RuntimeError + , getNextLine :: IO String + , putLine :: String -> IO () + } + +instance Show Context where + show :: Context -> String + show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) ++ "\nError: " ++ show (Context.error cxt) + +instance Eq Context where + (==) :: Context -> Context -> Bool + (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 && Context.error c1 == Context.error c2 emptyContext :: Context -emptyContext = Context { - funs = FunContext, - vars = emptyVarContext, - Context.error = Nothing -} +emptyContext = Context + { funs = FunContext + , vars = emptyVarContext + , Context.error = Nothing + , getNextLine = getLine + , putLine = putStrLn + } pattern ErrorContext :: Context pattern ErrorContext <- Context { Context.error = (Just _) } diff --git a/src/Execute.hs b/src/Execute.hs index f5e461e..5864921 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} module Execute where import Statement (Statement(Write, Read)) -import Context ( Context(error), pattern ErrorContext, setVar, setError ) +import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) import Error (RuntimeError(UnsupportedError, InvalidInputError)) import Evaluate ( evaluate ) import Control.Monad (foldM) @@ -11,14 +11,14 @@ import Text.Read (readMaybe) executeStatement :: Context -> Statement -> IO Context executeStatement c@ErrorContext _ = pure c -executeStatement cxt (Write expr) = do - let (cxt', x) = evaluate cxt expr +executeStatement cxt (Write expr) = + let (cxt', x) = evaluate cxt expr in case x of Nothing -> cxt' - Just res -> print res >> cxt' + Just res -> putLine cxt (show res) >> cxt' executeStatement cxt (Read name) = do - line <- getLine + line <- getNextLine cxt let val = readMaybe line :: Maybe Int case val of Nothing -> setError cxt $ InvalidInputError line diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 index 0000000..d7a0a67 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} \ No newline at end of file diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs new file mode 100644 index 0000000..328e791 --- /dev/null +++ b/test/Test/Execute.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE LambdaCase #-} +module Test.Execute where + +import Test.Tasty.HUnit (assertEqual) +import Statement (Expression(VariableName, Const), Statement (Skip, Write, Read)) +import Execute (execute) +import Context (Context(..), emptyContext, setVar, setError) +import Error (RuntimeError(VarNameError, UnsupportedError, InvalidInputError)) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, modifyIORef) +import qualified GHC.Err as Err + +initTestContext :: [String] -> IO (Context, IO [String]) +initTestContext input = do + inputsRef <- newIORef input + outputsRef <- newIORef [] + let getOutput :: IO [String] + getOutput = readIORef outputsRef + + let getTestLine :: IO String + getTestLine = atomicModifyIORef inputsRef (\case + i : is -> (is,i) -- the i becomes the return value + [] -> Err.error "fake inputs exhausted") + let putTestLine :: String -> IO () + putTestLine str = atomicModifyIORef outputsRef (\inputs -> (inputs ++ [str], ())) + + pure (emptyContext {getNextLine = getTestLine, putLine = putTestLine }, getOutput) + +unit_executeWrite :: IO () +unit_executeWrite = do + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + + (testContext, getOutput) <- initTestContext [] + exitContext <- execute testContext [writeConst] + output <- getOutput + assertEqual "write const" testContext exitContext + assertEqual "write const" ["1"] output + + (testContext, getOutput) <- initTestContext [] + exitContext <- execute testContext [writeVar] + output <- getOutput + context <- setError testContext (VarNameError "var") + assertEqual "write var fail" context exitContext + assertEqual "write var fail" [] output + + (testContext0, getOutput) <- initTestContext ["123"] + testContext <- setVar testContext0 "var" 123 + exitContext <- execute testContext [writeVar] + output <- getOutput + assertEqual "write var success" testContext exitContext + assertEqual "write var success" ["123"] output + +unit_executeUnsupported :: IO () +unit_executeUnsupported = do + let skip = Skip + + exitContext <- execute emptyContext [skip] + context <- setError emptyContext UnsupportedError + assertEqual "unsupported" context exitContext + +unit_executeRead :: IO () +unit_executeRead = do + let readVar = Read "var" + + (testContext, getOutput) <- initTestContext ["123"] + exitContext <- execute testContext [readVar] + output <- getOutput + context <- setVar testContext "var" 123 + assertEqual "read success" context exitContext + assertEqual "read success" [] output + + (testContext, getOutput) <- initTestContext ["fds"] + exitContext <- execute testContext [readVar] + output <- getOutput + context <- setError testContext (InvalidInputError "fds") + assertEqual "read failure" context exitContext + assertEqual "read failure" [] output From a2e5a44cd4f5cfa9b8f963e6db7187f9e67e0041 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 20 Nov 2022 12:16:03 +0100 Subject: [PATCH 12/75] Added missing dependency --- L-static-analyzer.cabal | 16 ++++++++++++++-- package.yaml | 1 + 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 2e805bf..535889a 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -25,7 +25,12 @@ source-repository head library exposed-modules: + Context + Error + Evaluate + Execute Lib + Statement other-modules: Paths_L_static_analyzer hs-source-dirs: @@ -33,6 +38,7 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , containers default-language: Haskell2010 executable L-static-analyzer-exe @@ -45,17 +51,23 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , containers default-language: Haskell2010 test-suite L-static-analyzer-test type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Test.hs other-modules: + Test.Execute Paths_L_static_analyzer hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - L-static-analyzer + HUnit + , L-static-analyzer , base >=4.7 && <5 + , containers + , tasty + , tasty-hunit default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 85e5a8e..d9f612a 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- containers ghc-options: - -Wall From c07b1c4e45391d7acb321a44ff88b6c54473becf Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 20 Nov 2022 17:45:29 +0100 Subject: [PATCH 13/75] Added multiline support --- src/Grammar.hs | 79 +++++++++++++++++++++++++----------------- src/Statement.hs | 5 +-- test/Test/Parsers.hs | 81 +++++++++++++++++++++++++++----------------- 3 files changed, 100 insertions(+), 65 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index adcfa57..d56ba54 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -83,47 +83,62 @@ expressionOperationsTable = expression :: Parser Expression expression = makeExprParser expressionTerm expressionOperationsTable -letVariable :: Parser Statement -letVariable = - Let <$> (lexeme name "Variable name") <*> (symbol ":=" *> expression) "Variable let" +singleton :: a -> [a] +singleton x = [x] -write :: Parser Statement -write = do - Write <$> (symbol "write" *> expression) "while statement" +letVariable :: Parser [Statement] +letVariable = singleton <$> (Let <$> (lexeme name "Variable name") <*> (symbol ":=" *> expression) "Variable let") -readVariable :: Parser Statement -readVariable = do - Read <$> (symbol "read" *> name "Read statement") +write :: Parser [Statement] +write = singleton . Write <$> (symbol "write" *> expression) "write statement" -while :: Parser Statement +readVariable :: Parser [Statement] +readVariable = singleton . Read <$> (symbol "read" *> name "Read statement") + +while :: Parser [Statement] while = - While - <$> (between (symbol "while") (symbol "do") expression "While condition") - <*> (statement "While statement") + singleton + <$> ( While + <$> (between (symbol "while") (symbol "do") expression "While condition") + <*> (statement "While statement") + ) -ifThenElse :: Parser Statement +ifThenElse :: Parser [Statement] ifThenElse = - If - <$> (symbol "if" *> expression "If condition") - <*> (symbol "then" *> statement "True statement") - <*> (symbol "else" *> statement "False Statement") - -funCallStatement :: Parser Statement + singleton + <$> ( If + <$> (symbol "if" *> expression "If condition") + <*> (symbol "then" *> statement "True statement") + <*> (symbol "else" *> statement "False Statement") + ) + +funCallStatement :: Parser [Statement] funCallStatement = - FunctionCallStatement - <$> (name "function name") - <*> (arguments "arguments") + singleton + <$> ( FunctionCallStatement + <$> (name "function name") + <*> (arguments "arguments") + ) where arguments :: Parser [Expression] arguments = (:) <$> expression <*> many expression -statement :: Parser Statement +skip :: Parser [Statement] +skip = [Skip] <$ symbol "skip" + +split :: Parser [Statement] +split = concat <$> (statement `sepBy1` symbol ";") + +statement :: Parser [Statement] statement = - choice - [ write, - readVariable, - while, - ifThenElse, - try funCallStatement, - letVariable - ] + try while <|> try ifThenElse + <|> (concat <$> (terms `sepBy1` symbol ";")) + where + terms = + choice + [ write, + readVariable, + skip, + try funCallStatement, + letVariable + ] diff --git a/src/Statement.hs b/src/Statement.hs index 157a26d..245a7e4 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -28,8 +28,9 @@ data Statement | FunctionCallStatement String [Expression] | Write Expression | Read String - | While Expression Statement - | If Expression Statement Statement + | While Expression [Statement] + | If Expression [Statement] [Statement] + | Skip deriving (Show, Eq) reservedKeywords :: [String] diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index b92405a..474d571 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -70,12 +70,12 @@ unit_let = do let success = parseSuccessful letVariable let fail = parseFailed letVariable - assertBool "to const" $ success "x := 1" (Let "x" (Const 1)) - assertBool "reassign" $ success "x := x" (Let "x" (VariableName "x")) + assertBool "to const" $ success "x := 1" [Let "x" (Const 1)] + assertBool "reassign" $ success "x := x" [Let "x" (VariableName "x")] assertBool "compicated expression" $ success "x := y % 4 + 2 * 3" - ( Let + [ Let "x" ( Application $ Addition @@ -90,7 +90,7 @@ unit_let = do (Const 3) ) ) - ) + ] assertBool "assign statement" $ fail "x := while 1 do 2" @@ -116,18 +116,22 @@ unit_while = do let success = parseSuccessful while let fail = parseFailed while - assertBool "simple while" $ success "while 1 do x := x" $ While (Const 1) (Let "x" (VariableName "x")) + assertBool "simple while" $ success "while 1 do x := x" [While (Const 1) [Let "x" (VariableName "x")]] assertBool "complicated expression" $ - success "while 1 + 2 do x := x" $ - While - (Application $ Addition (Const 1) (Const 2)) - (Let "x" (VariableName "x")) + success + "while 1 + 2 do x := x" + [ While + (Application $ Addition (Const 1) (Const 2)) + [Let "x" (VariableName "x")] + ] assertBool "function call" $ - success "while f 1 do x := x" $ - While - (FunctionCall "f" [Const 1]) - (Let "x" (VariableName "x")) + success + "while f 1 do x := x" + [ While + (FunctionCall "f" [Const 1]) + [Let "x" (VariableName "x")] + ] assertBool "just while fails" $ fail "while" assertBool "just while-do failes" $ fail "while do" @@ -140,11 +144,13 @@ unit_if = do let fail = parseFailed ifThenElse assertBool "simple if" $ - success "if 1 then a 1 else a 2" $ - If - (Const 1) - (FunctionCallStatement "a" [Const 1]) - (FunctionCallStatement "a" [Const 2]) + success + "if 1 then a 1 else a 2" + [ If + (Const 1) + [FunctionCallStatement "a" [Const 1]] + [FunctionCallStatement "a" [Const 2]] + ] assertBool "if fails with statement in condition" $ fail "if x := 1 then a 1 else a 2" @@ -153,18 +159,31 @@ unit_statement = do let success = parseSuccessful statement let fail = parseFailed statement - assertBool "function call" $ success "f 1 2 3" $ FunctionCallStatement "f" [Const 1, Const 2, Const 3] - assertBool "read variable" $ success "read x" $ Read "x" + assertBool "function call" $ success "f 1 2 3" [FunctionCallStatement "f" [Const 1, Const 2, Const 3]] + assertBool "read variable" $ success "read x" [Read "x"] assertBool "read expression fails" $ fail "read x + 2" - assertBool "write variable" $ success "write x" $ Write (VariableName "x") + assertBool "write variable" $ success "write x" [Write (VariableName "x")] assertBool "write complex expression" $ - success "write x + 2 * 3" $ - Write $ - Application $ - Addition - (VariableName "x") - ( Application $ - Multiplication - (Const 2) - (Const 3) - ) + success + "write x + 2 * 3" + [ Write $ + Application $ + Addition + (VariableName "x") + ( Application $ + Multiplication + (Const 2) + (Const 3) + ) + ] + assertBool "skip statement" $ success "skip" [Skip] + assertBool "multiplie statements" $ success "x := a; y := b" [Let "x" $ VariableName "a", Let "y" $ VariableName "b"] + assertBool "while with long body" $ + success + "while 1 do x := a; y := b" + [ While + (Const 1) + [ Let "x" $ VariableName "a", + Let "y" $ VariableName "b" + ] + ] From ea9d80b4b62fe5cde09d4a4ba9176477b5e11070 Mon Sep 17 00:00:00 2001 From: veron Date: Wed, 23 Nov 2022 20:05:52 +0100 Subject: [PATCH 14/75] echo application --- L-static-analyzer.cabal | 2 + app/Main.hs | 146 +++++++++++++++++++++++++++++++++++++++- package.yaml | 2 + 3 files changed, 148 insertions(+), 2 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 4d1835f..d8328b7 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -49,7 +49,9 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , filepath , megaparsec + , optparse-applicative , parser-combinators default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs index 4c6b30f..433b724 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,148 @@ module Main (main) where -import Lib +import Options.Applicative +import System.FilePath ((<.>)) +import Text.Printf (printf) +-- Это консольное приложение, которое умеет запускать один из двух парсеров на строке, +-- прочитанной из файла или переданной в качестве аргумента командной строки. +-- Тут используется пакет optparse-applicative, позволяющий задавать аргументы командной строки, +-- а также генерирует help и проводит обработку пользовательских ошибок. + +-- Для запуска приложения пишем stack run exe, дальше два минуса (--), после которых идут уже +-- аргументы командной строки нашего приложения. +-- Например, stack run exe -- --help выводит описание приложения и допустимых аргументов. + +-- optparse-applicative позволяет задать парсеры для отдельных аргументов командной строки, +-- а потом объединить их, используя (<*>) (см. actionParser) +-- при этом порядок аргументов командной строки будет произвольным. + +-- Каждый аргумент командной строки сопровождается модификаторами опций Mod. +-- Mod является моноидом, поэтому разные модификаторы можно объединять, используя (<>) +-- Некоторые модификаторы: +-- * short, принимающий значение типа Char, описывает короткое название аргумента +-- * long, принимающий String, описывает длинное название аргумента +-- * help, принимающий String, задает поясняющий аргумент текст +-- * value задает значение по умолчанию для аргумента +-- * metavar задает метапеременную, используемую в документации для значения аргумента + +-- Некоторые виды аргументов командной строки: +-- * flag -- не имеет непосредственно аргумента (как -r в rm -r). +-- Функция flag принимает первым аргументом значение по умолчанию, которое возвращается, если флаг не установлен, +-- а вторым аргументом -- значение, которое устанавливается, если флаг установлен. +-- Пример использования можно увидеть в parserTypeParser. +-- * switch == flag False True. Пример можно увидеть в dumpToStdoutParser. +-- * strOption -- строковый аргумент командной строки (как -o Main в ghc Main.hs -o Main) +-- * option -- аргумент, который можно прочитать при помощи read из класса Read +-- * strArgument -- строковый аргумент командной строки без отдельного флага (как Main.hs в ghc Main.hs -o Main) +-- * argument -- аргумент командной строки без отдельного флага, который можно прочитать при помощи read. + +-- Программа парсит аргументы командной строки при помощи execParser, +-- а потом запускает функцию runAction (логику приложения) main :: IO () -main = someFunc +main = do + runAction =<< execParser opts + where + -- Задает парсер аргументов actionParser, сопровождая его автоматической генерацией странички help. + opts = info (actionParser <**> helper) + ( fullDesc + <> progDesc "This application echoes input file." + <> header "Simple echo console application" + ) + +-- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом +data Action = Action + { input :: Input + , output :: Output + , dumpToStdout :: Bool } + deriving (Show) + +-- Парсер аргументов командной строки +actionParser :: Parser Action +actionParser = + Action <$> inputParser <*> outputParser <*> dumpToStdoutParser + +-- Основная функция приложения +runAction :: Action -> IO () +runAction (Action input output dump) = do + i <- getInput input -- подготавливаем входные данные + o <- getOutput output input -- подготавливаем файл для результат + runEcho i o + dumpIntoStdout dump i o -- если стоит соответствующий флаг, выводим результат работы приложения в консоль + +-- Тип входных данных +data Input = FileInput FilePath -- Имя входного файла + | StrInput String -- Строка, передаваемая аргументом командной строки + deriving (Show) + +-- Тип выходных данных +data Output = FileOutput FilePath -- Имя файла для результата + | DefaultOutput -- Дефолтное имя файла + deriving (Show) + +-- Парсер аргумента, специфицирующий, откуда брать входные данные +inputParser :: Parser Input +inputParser = fileInput <|> strInput + +-- Флаг -i/--input позволяет задать строку -- имя входного файла +fileInput :: Parser Input +fileInput = FileInput <$> strOption -- + ( short 'i' -- короткое имя флага (-i) + <> long "input" -- длинное имя флага (--input) + <> metavar "INPUT" -- как аргумент этой опции называется в документации + <> help "Input file" ) -- + +-- Можно не использовать флаг i, а просто написать входную строку (1+2 в stack run exe -- 1+2) +strInput :: Parser Input +strInput = StrInput <$> strArgument (metavar "STRING" <> help "String to be parsed") + +-- Парсер аргумента, специфицирующий, куда писать результат работы программы +outputParser :: Parser Output +outputParser = fileOutput <|> defaultOutput + +-- Флаг -o/--output позволяет задать строку -- имя выходного файла +fileOutput :: Parser Output +fileOutput = FileOutput <$> strOption + ( short 'o' + <> long "output" + <> metavar "OUTPUT" + <> help (printf "Output file. If not specified, output is INPUT.out. If INPUT is not specified, output is %s" defaultOutFile) + ) + +-- Если флаг -o не использован, выбираем дефолтное имя выходного файла +defaultOutput :: Parser Output +defaultOutput = pure DefaultOutput + +-- Флаг, специфицирующий, надо ли печатать результат работы приложения в консоль +dumpToStdoutParser :: Parser Bool +dumpToStdoutParser = switch + ( short 'd' + <> help "Render input and output into stdout" + ) + +-- Вспомогательная функция, подготавливающая входную строку -- из файла или непосредственно аргумента командной строки +getInput :: Input -> IO String +getInput (FileInput path) = readFile path +getInput (StrInput str) = return str + +-- Вспомогательная функция, подготавливающая имя файла для результата +getOutput :: Output -> Input -> IO FilePath +getOutput (FileOutput path) _ = return path -- если путь указан, берем его +getOutput _ (FileInput path) = return $ path <.> "out" -- иначе, если вход был из файла, добавляем к его имени out +getOutput _ _ = return defaultOutFile -- иначе берем дефолтное имя файла (bad style, не делайте так) + +-- Очень плохо, не надо так +defaultOutFile :: String +defaultOutFile = "str.out" + +-- Функция, запускающая правильный парсер и записывающая результат работы в выходной файл +runEcho :: String -> FilePath -> IO () +runEcho s path = + writeFile path (printf "%s" s) + +-- Функция, которая выводит результат работы программы в консоль +dumpIntoStdout :: Bool -> String -> FilePath -> IO () +dumpIntoStdout False _ _ = return () +dumpIntoStdout True i o = do + out <- readFile o + putStrLn $ printf "===================================\nInput:\n\n%s\n-----------------------------------\nOutput:\n\n%s\n===================================\n" i out diff --git a/package.yaml b/package.yaml index 05f959d..edaaa24 100644 --- a/package.yaml +++ b/package.yaml @@ -48,6 +48,8 @@ executables: - -with-rtsopts=-N dependencies: - L-static-analyzer + - filepath + - optparse-applicative tests: L-static-analyzer-test: From 363bb4337282b5ee60fa410a1b5aa8dcfb3798cf Mon Sep 17 00:00:00 2001 From: khbminus Date: Sat, 26 Nov 2022 14:25:59 +0100 Subject: [PATCH 15/75] Basic context --- L-static-analyzer.cabal | 12 +++--- app/Main.hs | 15 +++---- package.yaml | 1 + src/Context.hs | 37 ++++++------------ src/Evaluate.hs | 86 ++++++++++++++++++++++++++++++++++++----- src/Execute.hs | 54 +++++++++++++------------- test/Test/Execute.hs | 8 ++-- 7 files changed, 135 insertions(+), 78 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 1ab61da..1a8fdd5 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -41,7 +41,8 @@ library base >=4.7 && <5 , containers , megaparsec - , parser-combinator + , mtl + , parser-combinators default-language: Haskell2010 executable L-static-analyzer-exe @@ -56,6 +57,7 @@ executable L-static-analyzer-exe , base >=4.7 && <5 , containers , megaparsec + , mtl , parser-combinators default-language: Haskell2010 @@ -71,17 +73,15 @@ test-suite L-static-analyzer-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit - , L-static-analyzer - , base >=4.7 && <5 - , containers - , tasty , HUnit-approx , L-static-analyzer , base >=4.7 && <5 + , containers , hedgehog , hspec , hspec-megaparsec , megaparsec + , mtl , parser-combinators , tasty , tasty-discover diff --git a/app/Main.hs b/app/Main.hs index 7bcfa99..75f5781 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,8 @@ module Main (main) where import Statement(Statement(Write, Skip, Read), Expression(Const, VariableName)) -import Execute (run) -import Context (emptyContext) +--import Execute (run) +import Context (empty) main :: IO () main = do @@ -11,9 +11,10 @@ main = do let skip = Skip let readVar = Read "var" - run emptyContext [readVar, writeVar] - run emptyContext [readVar] - run emptyContext [writeVar] - run emptyContext [writeConst] - run emptyContext [skip] + print readVar +-- run singleton [readVar, writeVar] +-- run singleton [readVar] +-- run singleton [writeVar] +-- run singleton [writeConst] +-- run singleton [skip] diff --git a/package.yaml b/package.yaml index 7adc163..0648d54 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ dependencies: - containers - megaparsec - parser-combinators +- mtl ghc-options: - -Wall diff --git a/src/Context.hs b/src/Context.hs index e286567..57d1567 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE InstanceSigs #-} module Context where -import Error ( RuntimeError(VarNameError) ) import qualified Data.Map as Map data FunContext = FunContext deriving (Show, Eq) @@ -14,44 +12,33 @@ emptyVarContext = VarContext { context = Map.empty } data Context = Context { funs :: FunContext , vars :: VarContext - , error :: Maybe RuntimeError - , getNextLine :: IO String - , putLine :: String -> IO () + , input :: [String] + , output :: [String] } instance Show Context where show :: Context -> String - show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) ++ "\nError: " ++ show (Context.error cxt) + show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) instance Eq Context where (==) :: Context -> Context -> Bool - (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 && Context.error c1 == Context.error c2 + (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 -emptyContext :: Context -emptyContext = Context +empty :: Context +empty = Context { funs = FunContext , vars = emptyVarContext - , Context.error = Nothing - , getNextLine = getLine - , putLine = putStrLn + , input = [] + , output = [] } -pattern ErrorContext :: Context -pattern ErrorContext <- Context { Context.error = (Just _) } -getVar :: Context -> String -> (IO Context, Maybe Int) +getVar :: Context -> String -> Maybe Int getVar cxt var = let mp = context . vars $ cxt in - let x = Map.lookup var mp in - (case x of - Nothing -> setError cxt $ VarNameError var - Just _ -> pure cxt - , x) + Map.lookup var mp -setVar :: Context -> String -> Int -> IO Context +setVar :: Context -> String -> Int -> Context setVar cxt name val = let mp = context . vars $ cxt in - pure $ cxt { vars = VarContext $ Map.insert name val mp } - -setError :: Context -> RuntimeError -> IO Context -setError cxt err = pure $ cxt { Context.error = Just err } + cxt { vars = VarContext $ Map.insert name val mp } diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 3e9f566..193d07d 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,12 +1,80 @@ -module Evaluate where -import Statement (Expression (Const, FunctionCall, VariableName, Application)) -import Context ( setError, Context(), getVar ) -import Error ( RuntimeError(UnsupportedError) ) +{-# LANGUAGE BangPatterns #-} +module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where -evaluate :: Context -> Expression -> (IO Context, Maybe Int) -evaluate cxt (Const x) = (pure cxt, Just x) -evaluate cxt (VariableName var) = getVar cxt var +import Context (Context (..), getVar, setVar) +import Control.Monad.State.Lazy +import Data.Maybe (fromMaybe) +import Error (RuntimeError (UnsupportedError)) +import Statement (Expression (..), Operations (..), Statement (..)) -evaluate cxt (FunctionCall _ _) = (setError cxt UnsupportedError, Nothing) -- TODO -evaluate cxt (Application _) = (setError cxt UnsupportedError, Nothing) -- TODO +evaluateExpression :: Expression -> Context -> Int +evaluateExpression (Const x) _ = x +evaluateExpression (VariableName name) ctx = fromMaybe undefined (getVar ctx name) +evaluateExpression (FunctionCall _ _) _ = undefined +evaluateExpression (Application op) ctx = evaluateOp op ctx + where + evaluateOp :: Operations -> Context -> Int + evaluateOp (Addition lft rgt) ctx = evaluateExpression lft ctx + evaluateExpression rgt ctx + evaluateOp (Subtraction lft rgt) ctx = evaluateExpression lft ctx - evaluateExpression rgt ctx + evaluateOp (Division lft rgt) ctx = evaluateExpression lft ctx `div` evaluateExpression rgt ctx + evaluateOp (Multiplication lft rgt) ctx = evaluateExpression lft ctx * evaluateExpression rgt ctx + evaluateOp (Modulo lft rgt) ctx = evaluateExpression lft ctx `mod` evaluateExpression rgt ctx + evaluateOp (Equals lft rgt) ctx = fromBool $ evaluateExpression lft ctx == evaluateExpression rgt ctx + evaluateOp (NotEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx /= evaluateExpression rgt ctx + evaluateOp (Greater lft rgt) ctx = fromBool $ evaluateExpression lft ctx > evaluateExpression rgt ctx + evaluateOp (GreaterOrEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx >= evaluateExpression rgt ctx + evaluateOp (Less lft rgt) ctx = fromBool $ evaluateExpression lft ctx < evaluateExpression rgt ctx + evaluateOp (LessOrEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx <= evaluateExpression rgt ctx + evaluateOp (LazyAnd lft rgt) ctx = case evaluateExpression lft ctx of + 0 -> 0 + _ -> boolToInt $ evaluateExpression rgt ctx + evaluateOp (LazyOr lft rgt) ctx = case evaluateExpression lft ctx of + 0 -> boolToInt $ evaluateExpression rgt ctx + _ -> 1 + + fromBool :: Bool -> Int + fromBool True = 1 + fromBool False = 0 + + boolToInt :: Int -> Int + boolToInt 0 = 0 + boolToInt _ = 1 + +toBool :: Int -> Bool +toBool 0 = False +toBool _ = True + +evaluateOneStatement :: Statement -> State Context () +evaluateOneStatement (Let name value) = do + ctx <- get + let !value' = evaluateExpression value ctx + put $ setVar ctx name value' +evaluateOneStatement Skip = pure () +evaluateOneStatement (While expression statements) = do + ctx <- get + let !value = evaluateExpression expression ctx + if toBool value + then return () + else evaluateStatements statements +evaluateOneStatement (If expression trueStatements falseStatements) = do + ctx <- get + let !value = evaluateExpression expression ctx + if toBool value + then evaluateStatements trueStatements + else evaluateStatements falseStatements +evaluateOneStatement (FunctionCallStatement name args) = pure () +evaluateOneStatement (Write expr) = do + ctx <- get + let !value = evaluateExpression expr ctx + put ctx {output = output ctx ++ [show value]} +evaluateOneStatement (Read val) = do + ctx <- get + let value = 0 -- TODO: make it works + put (setVar ctx val value) {input = tail $ input ctx} + +evaluateStatements :: [Statement] -> State Context () +evaluateStatements [] = pure () +evaluateStatements (x : xs) = do + evaluateOneStatement x + evaluateStatements xs diff --git a/src/Execute.hs b/src/Execute.hs index 5864921..724ece5 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,37 +1,37 @@ {-# LANGUAGE PatternSynonyms #-} module Execute where import Statement (Statement(Write, Read)) -import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) +--import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) import Error (RuntimeError(UnsupportedError, InvalidInputError)) -import Evaluate ( evaluate ) +--import Evaluate ( evaluate ) import Control.Monad (foldM) import Text.Read (readMaybe) -executeStatement :: Context -> Statement -> IO Context -executeStatement c@ErrorContext _ = pure c +--executeStatement :: Context -> Statement -> IO Context +--executeStatement c@ErrorContext _ = pure c -executeStatement cxt (Write expr) = - let (cxt', x) = evaluate cxt expr in - case x of - Nothing -> cxt' - Just res -> putLine cxt (show res) >> cxt' +--executeStatement cxt (Write expr) = +-- let (cxt', x) = evaluate cxt expr in +-- case x of +-- Nothing -> cxt' +-- Just res -> putLine cxt (show res) >> cxt' +-- +--executeStatement cxt (Read name) = do +-- line <- getNextLine cxt +-- let val = readMaybe line :: Maybe Int +-- case val of +-- Nothing -> setError cxt $ InvalidInputError line +-- Just x -> setVar cxt name x +-- +--executeStatement cxt _ = setError cxt UnsupportedError -- TODO -executeStatement cxt (Read name) = do - line <- getNextLine cxt - let val = readMaybe line :: Maybe Int - case val of - Nothing -> setError cxt $ InvalidInputError line - Just x -> setVar cxt name x - -executeStatement cxt _ = setError cxt UnsupportedError -- TODO - -execute :: Context -> [Statement] -> IO Context -execute = foldM executeStatement - -run :: Context -> [Statement] -> IO () -run cxt sts = do - res <- execute cxt sts - case Context.error res of - Nothing -> putStrLn "Success!" - Just err -> putStrLn $ "Error: " ++ show err +--execute :: Context -> [Statement] -> IO Context +--execute = foldM executeStatement +-- +--run :: Context -> [Statement] -> IO () +--run cxt sts = do +-- res <- execute cxt sts +-- case Context.error res of +-- Nothing -> putStrLn "Success!" +-- Just err -> putStrLn $ "Error: " ++ show err diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index 328e791..fa9f5fe 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -4,7 +4,7 @@ module Test.Execute where import Test.Tasty.HUnit (assertEqual) import Statement (Expression(VariableName, Const), Statement (Skip, Write, Read)) import Execute (execute) -import Context (Context(..), emptyContext, setVar, setError) +import Context (Context(..), empty, setVar, setError) import Error (RuntimeError(VarNameError, UnsupportedError, InvalidInputError)) import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, modifyIORef) import qualified GHC.Err as Err @@ -23,7 +23,7 @@ initTestContext input = do let putTestLine :: String -> IO () putTestLine str = atomicModifyIORef outputsRef (\inputs -> (inputs ++ [str], ())) - pure (emptyContext {getNextLine = getTestLine, putLine = putTestLine }, getOutput) + pure (empty {getNextLine = getTestLine, putLine = putTestLine }, getOutput) unit_executeWrite :: IO () unit_executeWrite = do @@ -54,8 +54,8 @@ unit_executeUnsupported :: IO () unit_executeUnsupported = do let skip = Skip - exitContext <- execute emptyContext [skip] - context <- setError emptyContext UnsupportedError + exitContext <- execute empty [skip] + context <- setError empty UnsupportedError assertEqual "unsupported" context exitContext unit_executeRead :: IO () From c85e39dc12677ac14b13ed13944fb084712ad0e2 Mon Sep 17 00:00:00 2001 From: veron Date: Sun, 27 Nov 2022 15:14:01 +0100 Subject: [PATCH 16/75] cabal --- L-static-analyzer.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index d8328b7..1016839 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -25,6 +25,7 @@ source-repository head library exposed-modules: + CommandLineParser Grammar Lib Statement @@ -59,6 +60,7 @@ test-suite L-static-analyzer-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Test.Console Test.Parsers Paths_L_static_analyzer hs-source-dirs: From 5bc4753f27c8ff8e46b656a500c7b53ecfb147e6 Mon Sep 17 00:00:00 2001 From: veron Date: Sun, 27 Nov 2022 15:25:36 +0100 Subject: [PATCH 17/75] demo console --- L-static-analyzer.cabal | 10 +++- app/Main.hs | 117 +++------------------------------------ package.yaml | 8 ++- src/CommandLineParser.hs | 61 ++++++++++++++++++++ src/Context.hs | 60 ++++++++++++++++++++ src/Error.hs | 8 +++ src/Evaluate.hs | 12 ++++ src/Execute.hs | 37 +++++++++++++ src/Grammar.hs | 12 +++- src/Lib.hs | 6 -- test/Test/Console.hs | 27 +++++++++ 11 files changed, 240 insertions(+), 118 deletions(-) create mode 100644 src/CommandLineParser.hs create mode 100644 src/Context.hs create mode 100644 src/Error.hs create mode 100644 src/Evaluate.hs create mode 100644 src/Execute.hs delete mode 100644 src/Lib.hs create mode 100644 test/Test/Console.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 1016839..b679230 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -26,8 +26,11 @@ source-repository head library exposed-modules: CommandLineParser + Context + Error + Evaluate + Execute Grammar - Lib Statement other-modules: Paths_L_static_analyzer @@ -36,7 +39,9 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , containers , megaparsec + , optparse-applicative , parser-combinators default-language: Haskell2010 @@ -50,7 +55,7 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 - , filepath + , containers , megaparsec , optparse-applicative , parser-combinators @@ -71,6 +76,7 @@ test-suite L-static-analyzer-test , HUnit-approx , L-static-analyzer , base >=4.7 && <5 + , containers , hedgehog , hspec , hspec-megaparsec diff --git a/app/Main.hs b/app/Main.hs index 433b724..987b1e3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,8 @@ -module Main (main) where +module Main where import Options.Applicative -import System.FilePath ((<.>)) -import Text.Printf (printf) +import CommandLineParser (Action(..), actionParser, getInput, getVarContext, runInterpreter) +import Grammar (parseInput) -- Это консольное приложение, которое умеет запускать один из двух парсеров на строке, -- прочитанной из файла или переданной в качестве аргумента командной строки. @@ -26,17 +26,6 @@ import Text.Printf (printf) -- * value задает значение по умолчанию для аргумента -- * metavar задает метапеременную, используемую в документации для значения аргумента --- Некоторые виды аргументов командной строки: --- * flag -- не имеет непосредственно аргумента (как -r в rm -r). --- Функция flag принимает первым аргументом значение по умолчанию, которое возвращается, если флаг не установлен, --- а вторым аргументом -- значение, которое устанавливается, если флаг установлен. --- Пример использования можно увидеть в parserTypeParser. --- * switch == flag False True. Пример можно увидеть в dumpToStdoutParser. --- * strOption -- строковый аргумент командной строки (как -o Main в ghc Main.hs -o Main) --- * option -- аргумент, который можно прочитать при помощи read из класса Read --- * strArgument -- строковый аргумент командной строки без отдельного флага (как Main.hs в ghc Main.hs -o Main) --- * argument -- аргумент командной строки без отдельного флага, который можно прочитать при помощи read. - -- Программа парсит аргументы командной строки при помощи execParser, -- а потом запускает функцию runAction (логику приложения) main :: IO () @@ -46,103 +35,15 @@ main = do -- Задает парсер аргументов actionParser, сопровождая его автоматической генерацией странички help. opts = info (actionParser <**> helper) ( fullDesc - <> progDesc "This application echoes input file." - <> header "Simple echo console application" + <> progDesc "This application executes programms in L" + <> header "L interpreter" ) --- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом -data Action = Action - { input :: Input - , output :: Output - , dumpToStdout :: Bool } - deriving (Show) - --- Парсер аргументов командной строки -actionParser :: Parser Action -actionParser = - Action <$> inputParser <*> outputParser <*> dumpToStdoutParser - -- Основная функция приложения runAction :: Action -> IO () -runAction (Action input output dump) = do +runAction (Action input context) = do i <- getInput input -- подготавливаем входные данные - o <- getOutput output input -- подготавливаем файл для результат - runEcho i o - dumpIntoStdout dump i o -- если стоит соответствующий флаг, выводим результат работы приложения в консоль - --- Тип входных данных -data Input = FileInput FilePath -- Имя входного файла - | StrInput String -- Строка, передаваемая аргументом командной строки - deriving (Show) - --- Тип выходных данных -data Output = FileOutput FilePath -- Имя файла для результата - | DefaultOutput -- Дефолтное имя файла - deriving (Show) - --- Парсер аргумента, специфицирующий, откуда брать входные данные -inputParser :: Parser Input -inputParser = fileInput <|> strInput - --- Флаг -i/--input позволяет задать строку -- имя входного файла -fileInput :: Parser Input -fileInput = FileInput <$> strOption -- - ( short 'i' -- короткое имя флага (-i) - <> long "input" -- длинное имя флага (--input) - <> metavar "INPUT" -- как аргумент этой опции называется в документации - <> help "Input file" ) -- - --- Можно не использовать флаг i, а просто написать входную строку (1+2 в stack run exe -- 1+2) -strInput :: Parser Input -strInput = StrInput <$> strArgument (metavar "STRING" <> help "String to be parsed") - --- Парсер аргумента, специфицирующий, куда писать результат работы программы -outputParser :: Parser Output -outputParser = fileOutput <|> defaultOutput - --- Флаг -o/--output позволяет задать строку -- имя выходного файла -fileOutput :: Parser Output -fileOutput = FileOutput <$> strOption - ( short 'o' - <> long "output" - <> metavar "OUTPUT" - <> help (printf "Output file. If not specified, output is INPUT.out. If INPUT is not specified, output is %s" defaultOutFile) - ) - --- Если флаг -o не использован, выбираем дефолтное имя выходного файла -defaultOutput :: Parser Output -defaultOutput = pure DefaultOutput - --- Флаг, специфицирующий, надо ли печатать результат работы приложения в консоль -dumpToStdoutParser :: Parser Bool -dumpToStdoutParser = switch - ( short 'd' - <> help "Render input and output into stdout" - ) - --- Вспомогательная функция, подготавливающая входную строку -- из файла или непосредственно аргумента командной строки -getInput :: Input -> IO String -getInput (FileInput path) = readFile path -getInput (StrInput str) = return str - --- Вспомогательная функция, подготавливающая имя файла для результата -getOutput :: Output -> Input -> IO FilePath -getOutput (FileOutput path) _ = return path -- если путь указан, берем его -getOutput _ (FileInput path) = return $ path <.> "out" -- иначе, если вход был из файла, добавляем к его имени out -getOutput _ _ = return defaultOutFile -- иначе берем дефолтное имя файла (bad style, не делайте так) - --- Очень плохо, не надо так -defaultOutFile :: String -defaultOutFile = "str.out" - --- Функция, запускающая правильный парсер и записывающая результат работы в выходной файл -runEcho :: String -> FilePath -> IO () -runEcho s path = - writeFile path (printf "%s" s) + let sts = parseInput i + let varContext = getVarContext context + runInterpreter varContext sts --- Функция, которая выводит результат работы программы в консоль -dumpIntoStdout :: Bool -> String -> FilePath -> IO () -dumpIntoStdout False _ _ = return () -dumpIntoStdout True i o = do - out <- readFile o - putStrLn $ printf "===================================\nInput:\n\n%s\n-----------------------------------\nOutput:\n\n%s\n===================================\n" i out diff --git a/package.yaml b/package.yaml index edaaa24..353469d 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- containers - megaparsec - parser-combinators @@ -37,6 +38,9 @@ ghc-options: library: source-dirs: src + dependencies: + - containers + - optparse-applicative executables: L-static-analyzer-exe: @@ -48,7 +52,6 @@ executables: - -with-rtsopts=-N dependencies: - L-static-analyzer - - filepath - optparse-applicative tests: @@ -70,3 +73,6 @@ tests: - tasty-hunit - tasty-discover - L-static-analyzer + - HUnit + - tasty-hunit + - tasty diff --git a/src/CommandLineParser.hs b/src/CommandLineParser.hs new file mode 100644 index 0000000..cb5438e --- /dev/null +++ b/src/CommandLineParser.hs @@ -0,0 +1,61 @@ +module CommandLineParser where + +import qualified Options.Applicative as Optparse +import qualified Text.Megaparsec as Megaparsec +import qualified Grammar as LParser +import Text.Megaparsec ( () ) +import Context (VarContext, Context(..), setVarContext, emptyContext, emptyVarContext) +import Statement +import Execute (run) + +-- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом +data Action = Action + { input :: Input + , vars :: [String] } + deriving (Show) + + +-- Парсер аргументов командной строки +actionParser :: Optparse.Parser Action +actionParser = Action <$> inputParser <*> varsParser + +-- Тип входных данных +data Input = FileInput FilePath -- Имя входного файла + deriving (Show) + +-- Парсер аргумента, специфицирующий, откуда брать входные данные +inputParser :: Optparse.Parser Input +inputParser = fileInput + +varsParser :: Optparse.Parser [String] +varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar "VARS..." + +varArg :: LParser.Parser (String, Int) +varArg = (,) + <$> (LParser.lexeme LParser.name "Variable name") <*> (LParser.symbol "=" *> LParser.lexeme LParser.decimal "const value" ) "Variable argument" + + +getVarContext :: [String] -> VarContext +getVarContext (x:xs) = + let res = Megaparsec.parse varArg "" x in + case res of + Left err -> getVarContext xs + Right (var, val) -> setVarContext (getVarContext xs) var val +getVarContext [] = emptyVarContext + +-- Флаг -i/--input позволяет задать строку -- имя входного файла +fileInput :: Optparse.Parser Input +fileInput = FileInput <$> Optparse.strOption -- + ( Optparse.short 'i' -- короткое имя флага (-i) + <> Optparse.long "input" -- длинное имя флага (--input) + <> Optparse.metavar "INPUT" -- как аргумент этой опции называется в документации + <> Optparse.help "Input file" ) -- + +-- Вспомогательная функция, подготавливающая входную строку -- из файла или непосредственно аргумента командной строки +getInput :: Input -> IO String +getInput (FileInput path) = readFile path + +-- Функция, запускающая парсер и записывающая результат работы в стандартный вывод +runInterpreter :: VarContext -> [Statement] -> IO () +runInterpreter varcxt = run $ emptyContext { Context.vars = varcxt } + diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 index 0000000..b9e5bd9 --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE InstanceSigs #-} +module Context where +import Error ( RuntimeError(VarNameError) ) +import qualified Data.Map as Map + +data FunContext = FunContext deriving (Show, Eq) + +data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, Eq) + +emptyVarContext :: VarContext +emptyVarContext = VarContext { context = Map.empty } + +setVarContext :: VarContext -> String -> Int -> VarContext +setVarContext cxt var val = VarContext $ Map.insert var val $ context cxt + +data Context = Context + { funs :: FunContext + , vars :: VarContext + , error :: Maybe RuntimeError + , getNextLine :: IO String + , putLine :: String -> IO () + } + +instance Show Context where + show :: Context -> String + show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) ++ "\nError: " ++ show (Context.error cxt) + +instance Eq Context where + (==) :: Context -> Context -> Bool + (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 && Context.error c1 == Context.error c2 + +emptyContext :: Context +emptyContext = Context + { funs = FunContext + , vars = emptyVarContext + , Context.error = Nothing + , getNextLine = getLine + , putLine = putStrLn + } + +pattern ErrorContext :: Context +pattern ErrorContext <- Context { Context.error = (Just _) } + +getVar :: Context -> String -> (IO Context, Maybe Int) +getVar cxt var = + let mp = context . vars $ cxt in + let x = Map.lookup var mp in + (case x of + Nothing -> setError cxt $ VarNameError var + Just _ -> pure cxt + , x) + +setVar :: Context -> String -> Int -> Context +setVar cxt name val = + let mp = context . vars $ cxt in + cxt { vars = VarContext $ Map.insert name val mp } + +setError :: Context -> RuntimeError -> IO Context +setError cxt err = pure $ cxt { Context.error = Just err } diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 0000000..c0ae991 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,8 @@ +module Error where +import Statement(Expression) + +data RuntimeError = EvalError Expression + | VarNameError String + | UnsupportedError + | InvalidInputError String + deriving (Show, Eq) diff --git a/src/Evaluate.hs b/src/Evaluate.hs new file mode 100644 index 0000000..3e9f566 --- /dev/null +++ b/src/Evaluate.hs @@ -0,0 +1,12 @@ +module Evaluate where +import Statement (Expression (Const, FunctionCall, VariableName, Application)) +import Context ( setError, Context(), getVar ) +import Error ( RuntimeError(UnsupportedError) ) + + +evaluate :: Context -> Expression -> (IO Context, Maybe Int) +evaluate cxt (Const x) = (pure cxt, Just x) +evaluate cxt (VariableName var) = getVar cxt var + +evaluate cxt (FunctionCall _ _) = (setError cxt UnsupportedError, Nothing) -- TODO +evaluate cxt (Application _) = (setError cxt UnsupportedError, Nothing) -- TODO diff --git a/src/Execute.hs b/src/Execute.hs new file mode 100644 index 0000000..91df94b --- /dev/null +++ b/src/Execute.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE PatternSynonyms #-} +module Execute where +import Statement (Statement(Write, Read)) +import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) +import Error (RuntimeError(UnsupportedError, InvalidInputError)) +import Evaluate ( evaluate ) +import Control.Monad (foldM) +import Text.Read (readMaybe) + + +executeStatement :: Context -> Statement -> IO Context +executeStatement c@ErrorContext _ = pure c + +executeStatement cxt (Write expr) = + let (cxt', x) = evaluate cxt expr in + case x of + Nothing -> cxt' + Just res -> putLine cxt (show res) >> cxt' + +executeStatement cxt (Read name) = do + line <- getNextLine cxt + let val = readMaybe line :: Maybe Int + case val of + Nothing -> setError cxt $ InvalidInputError line + Just x -> pure $ setVar cxt name x + +executeStatement cxt _ = setError cxt UnsupportedError -- TODO + +execute :: Context -> [Statement] -> IO Context +execute = foldM executeStatement + +run :: Context -> [Statement] -> IO () +run cxt sts = do + res <- execute cxt sts + case Context.error res of + Nothing -> putStrLn "Success!" + Just err -> putStrLn $ "Error: " ++ show err diff --git a/src/Grammar.hs b/src/Grammar.hs index d56ba54..4e15390 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -19,8 +19,11 @@ lexeme = L.lexeme sc symbol :: String -> Parser String symbol = L.symbol sc +decimal :: Parser Int +decimal = L.decimal + constValue :: Parser Expression -constValue = Const <$> lexeme L.decimal "const value" +constValue = Const <$> lexeme decimal "const value" name :: Parser String name = (lexeme . try) (p >>= check) @@ -142,3 +145,10 @@ statement = try funCallStatement, letVariable ] + + +parseInput :: String -> [Statement] +parseInput input = let res = parse statement "" input in + case res of + Left err -> error (show err) + Right sts -> sts diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff27..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/test/Test/Console.hs b/test/Test/Console.hs new file mode 100644 index 0000000..9a9f157 --- /dev/null +++ b/test/Test/Console.hs @@ -0,0 +1,27 @@ +module Test.Console where + +import Grammar (Parser) +import CommandLineParser (varArg) +import Test.HUnit +import Text.Megaparsec + +parseSuccessful :: Eq a => Parser a -> String -> a -> Bool +parseSuccessful parser line result = case parse (parser <* eof) "" line of + Left _ -> False + Right a -> a == result + +parseFailed :: Parser a -> String -> Bool +parseFailed parser line = case parse (parser <* eof) "" line of + Left _ -> True + Right _ -> False + +unit_varParser = do + let success = parseSuccessful varArg + let fail = parseFailed varArg + + assertBool "1" $ success "x=10" ("x", 10) + assertBool "3" $ success "x=0" ("x", 0) + + assertBool "4" $ fail "x tr=1" + assertBool "5" $ fail "1tr=5" + assertBool "6" $ fail "x=vr" From 7fad85e40f95f45c9c64d566e7416d80f7a6a4f0 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 16:14:36 +0100 Subject: [PATCH 18/75] Get rid of need of Context in parser --- src/Grammar.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index d56ba54..0ae4b93 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -19,6 +19,9 @@ lexeme = L.lexeme sc symbol :: String -> Parser String symbol = L.symbol sc +number :: Parser Int +number = lexeme L.decimal "number" + constValue :: Parser Expression constValue = Const <$> lexeme L.decimal "const value" @@ -35,10 +38,10 @@ varName = VariableName <$> name funCall :: Parser Expression funCall = do - FunctionCall <$> (lexeme name "Function name") <*> (arguments "arguments") + FunctionCall <$> (lexeme name "Function name") <*> (lexeme . parens) (arguments "arguments") where arguments :: Parser [Expression] - arguments = (:) <$> expression <*> many expression + arguments = expression `sepBy` lexeme (symbol ",") parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") @@ -116,12 +119,12 @@ funCallStatement :: Parser [Statement] funCallStatement = singleton <$> ( FunctionCallStatement - <$> (name "function name") - <*> (arguments "arguments") + <$> (lexeme name "Function name") + <*> (lexeme . parens) (arguments "arguments") ) where arguments :: Parser [Expression] - arguments = (:) <$> expression <*> many expression + arguments = expression `sepBy` lexeme (symbol ",") skip :: Parser [Statement] skip = [Skip] <$ symbol "skip" From 5b9de72c8d64b870eb6acb12d8989aacb987b326 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 16:55:11 +0100 Subject: [PATCH 19/75] Fixed tests --- test/Test/Execute.hs | 150 +++++++++++++++++++++---------------------- test/Test/Parsers.hs | 38 +++++------ 2 files changed, 94 insertions(+), 94 deletions(-) diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index fa9f5fe..6e413d8 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -1,77 +1,77 @@ {-# LANGUAGE LambdaCase #-} module Test.Execute where - -import Test.Tasty.HUnit (assertEqual) -import Statement (Expression(VariableName, Const), Statement (Skip, Write, Read)) -import Execute (execute) -import Context (Context(..), empty, setVar, setError) -import Error (RuntimeError(VarNameError, UnsupportedError, InvalidInputError)) -import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, modifyIORef) -import qualified GHC.Err as Err - -initTestContext :: [String] -> IO (Context, IO [String]) -initTestContext input = do - inputsRef <- newIORef input - outputsRef <- newIORef [] - let getOutput :: IO [String] - getOutput = readIORef outputsRef - - let getTestLine :: IO String - getTestLine = atomicModifyIORef inputsRef (\case - i : is -> (is,i) -- the i becomes the return value - [] -> Err.error "fake inputs exhausted") - let putTestLine :: String -> IO () - putTestLine str = atomicModifyIORef outputsRef (\inputs -> (inputs ++ [str], ())) - - pure (empty {getNextLine = getTestLine, putLine = putTestLine }, getOutput) - -unit_executeWrite :: IO () -unit_executeWrite = do - let writeConst = Write (Const 1) - let writeVar = Write (VariableName "var") - - (testContext, getOutput) <- initTestContext [] - exitContext <- execute testContext [writeConst] - output <- getOutput - assertEqual "write const" testContext exitContext - assertEqual "write const" ["1"] output - - (testContext, getOutput) <- initTestContext [] - exitContext <- execute testContext [writeVar] - output <- getOutput - context <- setError testContext (VarNameError "var") - assertEqual "write var fail" context exitContext - assertEqual "write var fail" [] output - - (testContext0, getOutput) <- initTestContext ["123"] - testContext <- setVar testContext0 "var" 123 - exitContext <- execute testContext [writeVar] - output <- getOutput - assertEqual "write var success" testContext exitContext - assertEqual "write var success" ["123"] output - -unit_executeUnsupported :: IO () -unit_executeUnsupported = do - let skip = Skip - - exitContext <- execute empty [skip] - context <- setError empty UnsupportedError - assertEqual "unsupported" context exitContext - -unit_executeRead :: IO () -unit_executeRead = do - let readVar = Read "var" - - (testContext, getOutput) <- initTestContext ["123"] - exitContext <- execute testContext [readVar] - output <- getOutput - context <- setVar testContext "var" 123 - assertEqual "read success" context exitContext - assertEqual "read success" [] output - - (testContext, getOutput) <- initTestContext ["fds"] - exitContext <- execute testContext [readVar] - output <- getOutput - context <- setError testContext (InvalidInputError "fds") - assertEqual "read failure" context exitContext - assertEqual "read failure" [] output +-- +--import Test.Tasty.HUnit (assertEqual) +--import Statement (Expression(VariableName, Const), Statement (Skip, Write, Read)) +--import Execute (execute) +--import Context (Context(..), empty, setVar, setError) +--import Error (RuntimeError(VarNameError, UnsupportedError, InvalidInputError)) +--import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, modifyIORef) +--import qualified GHC.Err as Err +-- +--initTestContext :: [String] -> IO (Context, IO [String]) +--initTestContext input = do +-- inputsRef <- newIORef input +-- outputsRef <- newIORef [] +-- let getOutput :: IO [String] +-- getOutput = readIORef outputsRef +-- +-- let getTestLine :: IO String +-- getTestLine = atomicModifyIORef inputsRef (\case +-- i : is -> (is,i) -- the i becomes the return value +-- [] -> Err.error "fake inputs exhausted") +-- let putTestLine :: String -> IO () +-- putTestLine str = atomicModifyIORef outputsRef (\inputs -> (inputs ++ [str], ())) +-- +-- pure (empty {getNextLine = getTestLine, putLine = putTestLine }, getOutput) +-- +--unit_executeWrite :: IO () +--unit_executeWrite = do +-- let writeConst = Write (Const 1) +-- let writeVar = Write (VariableName "var") +-- +-- (testContext, getOutput) <- initTestContext [] +-- exitContext <- execute testContext [writeConst] +-- output <- getOutput +-- assertEqual "write const" testContext exitContext +-- assertEqual "write const" ["1"] output +-- +-- (testContext, getOutput) <- initTestContext [] +-- exitContext <- execute testContext [writeVar] +-- output <- getOutput +-- context <- setError testContext (VarNameError "var") +-- assertEqual "write var fail" context exitContext +-- assertEqual "write var fail" [] output +-- +-- (testContext0, getOutput) <- initTestContext ["123"] +-- testContext <- setVar testContext0 "var" 123 +-- exitContext <- execute testContext [writeVar] +-- output <- getOutput +-- assertEqual "write var success" testContext exitContext +-- assertEqual "write var success" ["123"] output +-- +--unit_executeUnsupported :: IO () +--unit_executeUnsupported = do +-- let skip = Skip +-- +-- exitContext <- execute empty [skip] +-- context <- setError empty UnsupportedError +-- assertEqual "unsupported" context exitContext +-- +--unit_executeRead :: IO () +--unit_executeRead = do +-- let readVar = Read "var" +-- +-- (testContext, getOutput) <- initTestContext ["123"] +-- exitContext <- execute testContext [readVar] +-- output <- getOutput +-- context <- setVar testContext "var" 123 +-- assertEqual "read success" context exitContext +-- assertEqual "read success" [] output +-- +-- (testContext, getOutput) <- initTestContext ["fds"] +-- exitContext <- execute testContext [readVar] +-- output <- getOutput +-- context <- setError testContext (InvalidInputError "fds") +-- assertEqual "read failure" context exitContext +-- assertEqual "read failure" [] output diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 474d571..4e0e9d8 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -94,22 +94,22 @@ unit_let = do assertBool "assign statement" $ fail "x := while 1 do 2" --- TODO: uncomment this (see Grammar.hs for details) --- assertBool "assign function call" $ --- success --- "loooooong := function first second third 1 (2 + 3)" --- ( Let --- "loooooong" --- ( FunctionCall --- "function" --- [ VariableName "first" --- , VariableName "second" --- , VariableName "third" --- , Const 1 --- , Application $ Addition (Const 2) (Const 3) --- ] --- ) --- ) + -- TODO: uncomment this (see Grammar.hs for details) + assertBool "assign function call" $ + success + "loooooong := function(first, second, third, 1, 2 + 3)" + [ Let + "loooooong" + ( FunctionCall + "function" + [ VariableName "first", + VariableName "second", + VariableName "third", + Const 1, + Application $ Addition (Const 2) (Const 3) + ] + ) + ] unit_while :: IO () unit_while = do @@ -127,7 +127,7 @@ unit_while = do assertBool "function call" $ success - "while f 1 do x := x" + "while f(1) do x := x" [ While (FunctionCall "f" [Const 1]) [Let "x" (VariableName "x")] @@ -145,7 +145,7 @@ unit_if = do assertBool "simple if" $ success - "if 1 then a 1 else a 2" + "if 1 then a(1) else a(2)" [ If (Const 1) [FunctionCallStatement "a" [Const 1]] @@ -159,7 +159,7 @@ unit_statement = do let success = parseSuccessful statement let fail = parseFailed statement - assertBool "function call" $ success "f 1 2 3" [FunctionCallStatement "f" [Const 1, Const 2, Const 3]] + assertBool "function call" $ success "f(1, 2, 3)" [FunctionCallStatement "f" [Const 1, Const 2, Const 3]] assertBool "read variable" $ success "read x" [Read "x"] assertBool "read expression fails" $ fail "read x + 2" assertBool "write variable" $ success "write x" [Write (VariableName "x")] From bdc45da0fa655b261a956ed5b02e5276b3e6330a Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 16:55:27 +0100 Subject: [PATCH 20/75] Removed junk line --- test/Test/Parsers.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 4e0e9d8..4fd67bf 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -94,7 +94,6 @@ unit_let = do assertBool "assign statement" $ fail "x := while 1 do 2" - -- TODO: uncomment this (see Grammar.hs for details) assertBool "assign function call" $ success "loooooong := function(first, second, third, 1, 2 + 3)" From 4195f380a0d5eff21a5d18b92fb198c56577e604 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 19:10:44 +0100 Subject: [PATCH 21/75] First iteration of run function --- src/Context.hs | 18 +++++++++------- src/Evaluate.hs | 4 ++-- src/Execute.hs | 56 +++++++++++++++++++------------------------------ 3 files changed, 33 insertions(+), 45 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 57d1567..798f72a 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -4,21 +4,23 @@ import qualified Data.Map as Map data FunContext = FunContext deriving (Show, Eq) -data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, Eq) +newtype VarContext = VarContext {context :: Map.Map String Int} deriving (Show, Eq) + +data InputSource = InputSource { fileName :: String, inputLines :: [String] } deriving (Show) emptyVarContext :: VarContext emptyVarContext = VarContext { context = Map.empty } -data Context = Context +data Context = Context { funs :: FunContext , vars :: VarContext - , input :: [String] + , input :: InputSource , output :: [String] - } + } deriving Show -instance Show Context where - show :: Context -> String - show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) +--instance Show Context where +-- show :: Context -> String +-- show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) instance Eq Context where (==) :: Context -> Context -> Bool @@ -28,7 +30,7 @@ empty :: Context empty = Context { funs = FunContext , vars = emptyVarContext - , input = [] + , input = InputSource "null" [] , output = [] } diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 193d07d..2e92245 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -2,7 +2,7 @@ module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where -import Context (Context (..), getVar, setVar) +import Context (Context (..), InputSource (..), getVar, setVar) import Control.Monad.State.Lazy import Data.Maybe (fromMaybe) import Error (RuntimeError (UnsupportedError)) @@ -71,7 +71,7 @@ evaluateOneStatement (Write expr) = do evaluateOneStatement (Read val) = do ctx <- get let value = 0 -- TODO: make it works - put (setVar ctx val value) {input = tail $ input ctx} + put (setVar ctx val value) {input = (input ctx) {inputLines = tail $ inputLines $ input ctx}} evaluateStatements :: [Statement] -> State Context () evaluateStatements [] = pure () diff --git a/src/Execute.hs b/src/Execute.hs index 724ece5..79d22a4 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,37 +1,23 @@ -{-# LANGUAGE PatternSynonyms #-} -module Execute where -import Statement (Statement(Write, Read)) ---import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) -import Error (RuntimeError(UnsupportedError, InvalidInputError)) ---import Evaluate ( evaluate ) -import Control.Monad (foldM) -import Text.Read (readMaybe) +module Execute(run) where +import Context (Context (..), InputSource (..)) +import Control.Monad.State.Lazy +import Evaluate (evaluateStatements) +import Grammar (statement) +import Text.Megaparsec (runParser, eof) +import Text.Megaparsec.Error (ParseErrorBundle) +import Data.Void (Void) ---executeStatement :: Context -> Statement -> IO Context ---executeStatement c@ErrorContext _ = pure c - ---executeStatement cxt (Write expr) = --- let (cxt', x) = evaluate cxt expr in --- case x of --- Nothing -> cxt' --- Just res -> putLine cxt (show res) >> cxt' --- ---executeStatement cxt (Read name) = do --- line <- getNextLine cxt --- let val = readMaybe line :: Maybe Int --- case val of --- Nothing -> setError cxt $ InvalidInputError line --- Just x -> setVar cxt name x --- ---executeStatement cxt _ = setError cxt UnsupportedError -- TODO - ---execute :: Context -> [Statement] -> IO Context ---execute = foldM executeStatement --- ---run :: Context -> [Statement] -> IO () ---run cxt sts = do --- res <- execute cxt sts --- case Context.error res of --- Nothing -> putStrLn "Success!" --- Just err -> putStrLn $ "Error: " ++ show err +run :: State Context (Maybe (ParseErrorBundle String Void)) +run = do + ctx <- get + case (inputLines . input) ctx of + [] -> return Nothing + (x : xs) -> do + case runParser (statement <* eof) (fileName $ input ctx) x of + Left err -> return $ Just err + Right statements -> + do + put ctx {input = (input ctx) {inputLines = xs}} + evaluateStatements statements + run From 853266d1fc957040cb3576c05d05c4e28f4a2728 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 19:12:48 +0100 Subject: [PATCH 22/75] Refactor of Context.hs --- src/Context.hs | 55 +++++++++++++++++++++++++------------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 798f72a..4193894 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,46 +1,45 @@ {-# LANGUAGE InstanceSigs #-} -module Context where + +module Context(Context(..), InputSource(..), newContext, getVar, setVar) where + import qualified Data.Map as Map data FunContext = FunContext deriving (Show, Eq) newtype VarContext = VarContext {context :: Map.Map String Int} deriving (Show, Eq) -data InputSource = InputSource { fileName :: String, inputLines :: [String] } deriving (Show) +data InputSource = InputSource {fileName :: String, inputLines :: [String]} deriving (Show) emptyVarContext :: VarContext -emptyVarContext = VarContext { context = Map.empty } +emptyVarContext = VarContext {context = Map.empty} data Context = Context - { funs :: FunContext - , vars :: VarContext - , input :: InputSource - , output :: [String] - } deriving Show - ---instance Show Context where --- show :: Context -> String --- show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) + { funs :: FunContext, + vars :: VarContext, + input :: InputSource, + output :: [String] + } + deriving (Show) instance Eq Context where - (==) :: Context -> Context -> Bool - (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 - -empty :: Context -empty = Context - { funs = FunContext - , vars = emptyVarContext - , input = InputSource "null" [] - , output = [] + (==) :: Context -> Context -> Bool + (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 + +newContext :: InputSource -> Context +newContext i = + Context + { funs = FunContext, + vars = emptyVarContext, + input = i, + output = [] } - getVar :: Context -> String -> Maybe Int -getVar cxt var = - let mp = context . vars $ cxt in - Map.lookup var mp +getVar cxt var = + let mp = context . vars $ cxt + in Map.lookup var mp setVar :: Context -> String -> Int -> Context -setVar cxt name val = - let mp = context . vars $ cxt in - cxt { vars = VarContext $ Map.insert name val mp } +setVar cxt name val = + let mp = context . vars $ cxt + in cxt {vars = VarContext $ Map.insert name val mp} From 1fc8b6f6e19a403edc3f672b7fa31ae6ec41ca42 Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 19:24:14 +0100 Subject: [PATCH 23/75] Changed run signature to make read work read finally works, but run now need instructions to run --- app/Main.hs | 15 ++++++++------- src/Evaluate.hs | 11 ++++++++--- src/Execute.hs | 16 ++++++---------- 3 files changed, 22 insertions(+), 20 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 75f5781..50867aa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,16 +2,17 @@ module Main (main) where import Statement(Statement(Write, Skip, Read), Expression(Const, VariableName)) --import Execute (run) -import Context (empty) +--import Context (empty) main :: IO () main = do - let writeConst = Write (Const 1) - let writeVar = Write (VariableName "var") - let skip = Skip - let readVar = Read "var" - - print readVar + putStrLn "Hello World!" +-- let writeConst = Write (Const 1) +-- let writeVar = Write (VariableName "var") +-- let skip = Skip +-- let readVar = Read "var" +-- +-- print readVar -- run singleton [readVar, writeVar] -- run singleton [readVar] -- run singleton [writeVar] diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 2e92245..3b10ea1 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -5,8 +5,9 @@ module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) w import Context (Context (..), InputSource (..), getVar, setVar) import Control.Monad.State.Lazy import Data.Maybe (fromMaybe) -import Error (RuntimeError (UnsupportedError)) import Statement (Expression (..), Operations (..), Statement (..)) +import Grammar (number) +import Text.Megaparsec (runParser, eof) evaluateExpression :: Expression -> Context -> Int evaluateExpression (Const x) _ = x @@ -70,8 +71,12 @@ evaluateOneStatement (Write expr) = do put ctx {output = output ctx ++ [show value]} evaluateOneStatement (Read val) = do ctx <- get - let value = 0 -- TODO: make it works - put (setVar ctx val value) {input = (input ctx) {inputLines = tail $ inputLines $ input ctx}} + case (inputLines . input) ctx of + [] -> undefined -- FIXME + (x : xs) -> do + case runParser (number <* eof) (fileName $ input ctx) x of + Left _ -> undefined -- FIXME + Right value -> put (setVar ctx val value) {input = (input ctx) {inputLines = xs}} evaluateStatements :: [Statement] -> State Context () evaluateStatements [] = pure () diff --git a/src/Execute.hs b/src/Execute.hs index 79d22a4..e3c8026 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,6 +1,6 @@ module Execute(run) where -import Context (Context (..), InputSource (..)) +import Context (Context (..)) import Control.Monad.State.Lazy import Evaluate (evaluateStatements) import Grammar (statement) @@ -8,16 +8,12 @@ import Text.Megaparsec (runParser, eof) import Text.Megaparsec.Error (ParseErrorBundle) import Data.Void (Void) -run :: State Context (Maybe (ParseErrorBundle String Void)) -run = do - ctx <- get - case (inputLines . input) ctx of - [] -> return Nothing - (x : xs) -> do - case runParser (statement <* eof) (fileName $ input ctx) x of +run :: String -> [String] -> State Context (Maybe (ParseErrorBundle String Void)) +run _ [] = return Nothing +run fileName (x : xs) = + case runParser (statement <* eof) fileName x of Left err -> return $ Just err Right statements -> do - put ctx {input = (input ctx) {inputLines = xs}} evaluateStatements statements - run + run fileName xs From 9d37e8cd74b0add7665db8ddef17037254f24732 Mon Sep 17 00:00:00 2001 From: veron Date: Sun, 27 Nov 2022 20:47:03 +0100 Subject: [PATCH 24/75] add interactive mode --- app/Main.hs | 68 ++++++++++++++++++++++------------------ src/CommandLineParser.hs | 28 +++++++---------- src/Grammar.hs | 8 ++--- 3 files changed, 51 insertions(+), 53 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 987b1e3..e4243f4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,30 +1,12 @@ module Main where import Options.Applicative -import CommandLineParser (Action(..), actionParser, getInput, getVarContext, runInterpreter) +import CommandLineParser (Action(..), actionParser, getInput, getVarContext, runInterpreter, Input(..)) import Grammar (parseInput) - --- Это консольное приложение, которое умеет запускать один из двух парсеров на строке, --- прочитанной из файла или переданной в качестве аргумента командной строки. --- Тут используется пакет optparse-applicative, позволяющий задавать аргументы командной строки, --- а также генерирует help и проводит обработку пользовательских ошибок. - --- Для запуска приложения пишем stack run exe, дальше два минуса (--), после которых идут уже --- аргументы командной строки нашего приложения. --- Например, stack run exe -- --help выводит описание приложения и допустимых аргументов. - --- optparse-applicative позволяет задать парсеры для отдельных аргументов командной строки, --- а потом объединить их, используя (<*>) (см. actionParser) --- при этом порядок аргументов командной строки будет произвольным. - --- Каждый аргумент командной строки сопровождается модификаторами опций Mod. --- Mod является моноидом, поэтому разные модификаторы можно объединять, используя (<>) --- Некоторые модификаторы: --- * short, принимающий значение типа Char, описывает короткое название аргумента --- * long, принимающий String, описывает длинное название аргумента --- * help, принимающий String, задает поясняющий аргумент текст --- * value задает значение по умолчанию для аргумента --- * metavar задает метапеременную, используемую в документации для значения аргумента +import Context (emptyContext, Context(..)) +import Execute (execute) +import Control.Monad (when) +import System.IO -- Программа парсит аргументы командной строки при помощи execParser, -- а потом запускает функцию runAction (логику приложения) @@ -39,11 +21,37 @@ main = do <> header "L interpreter" ) --- Основная функция приложения runAction :: Action -> IO () -runAction (Action input context) = do - i <- getInput input -- подготавливаем входные данные - let sts = parseInput i - let varContext = getVarContext context - runInterpreter varContext sts - +runAction (Action input@(FileInput _) context) = do + i <- getInput input + let parsed = parseInput i + case parsed of + Left err -> print err + Right sts -> let varContext = getVarContext context in + runInterpreter varContext sts + +-- выход: q +-- TODO: STYLE FIX!!! +runAction (Action Interactive context) = interpret $ emptyContext { Context.vars = getVarContext context } + where + interpret :: Context -> IO () + interpret cxt = do + line <- prompt "L: " + when (line /= "q") $ + let parsed = parseInput line in + case parsed of + Left err -> print err >> interpret cxt + Right sts -> do + newcxt <- execute cxt sts + case newcxt of + Context { Context.error = Just err } -> do + print err + interpret $ newcxt { Context.error = Nothing} + _ -> do + interpret newcxt + +prompt :: String -> IO String +prompt text = do + putStr text + hFlush stdout + getLine \ No newline at end of file diff --git a/src/CommandLineParser.hs b/src/CommandLineParser.hs index cb5438e..a63e971 100644 --- a/src/CommandLineParser.hs +++ b/src/CommandLineParser.hs @@ -3,7 +3,7 @@ module CommandLineParser where import qualified Options.Applicative as Optparse import qualified Text.Megaparsec as Megaparsec import qualified Grammar as LParser -import Text.Megaparsec ( () ) +import Text.Megaparsec ( (), (<|>) ) import Context (VarContext, Context(..), setVarContext, emptyContext, emptyVarContext) import Statement import Execute (run) @@ -14,18 +14,23 @@ data Action = Action , vars :: [String] } deriving (Show) - -- Парсер аргументов командной строки actionParser :: Optparse.Parser Action -actionParser = Action <$> inputParser <*> varsParser +actionParser = Action <$> (inputParser <|> pure Interactive) <*> varsParser -- Тип входных данных data Input = FileInput FilePath -- Имя входного файла + | Interactive deriving (Show) -- Парсер аргумента, специфицирующий, откуда брать входные данные +-- Флаг -i/--input позволяет задать строку -- имя входного файла inputParser :: Optparse.Parser Input -inputParser = fileInput +inputParser = FileInput <$> Optparse.strOption + ( Optparse.short 'i' -- короткое имя флага (-i) + <> Optparse.long "input" -- длинное имя флага (--input) + <> Optparse.metavar "INPUT" -- как аргумент этой опции называется в документации + <> Optparse.help "Input file" ) varsParser :: Optparse.Parser [String] varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar "VARS..." @@ -34,28 +39,17 @@ varArg :: LParser.Parser (String, Int) varArg = (,) <$> (LParser.lexeme LParser.name "Variable name") <*> (LParser.symbol "=" *> LParser.lexeme LParser.decimal "const value" ) "Variable argument" - getVarContext :: [String] -> VarContext getVarContext (x:xs) = let res = Megaparsec.parse varArg "" x in case res of - Left err -> getVarContext xs + Left err -> Prelude.error $ show err Right (var, val) -> setVarContext (getVarContext xs) var val getVarContext [] = emptyVarContext --- Флаг -i/--input позволяет задать строку -- имя входного файла -fileInput :: Optparse.Parser Input -fileInput = FileInput <$> Optparse.strOption -- - ( Optparse.short 'i' -- короткое имя флага (-i) - <> Optparse.long "input" -- длинное имя флага (--input) - <> Optparse.metavar "INPUT" -- как аргумент этой опции называется в документации - <> Optparse.help "Input file" ) -- - --- Вспомогательная функция, подготавливающая входную строку -- из файла или непосредственно аргумента командной строки getInput :: Input -> IO String getInput (FileInput path) = readFile path +getInput Interactive = getLine --- Функция, запускающая парсер и записывающая результат работы в стандартный вывод runInterpreter :: VarContext -> [Statement] -> IO () runInterpreter varcxt = run $ emptyContext { Context.vars = varcxt } - diff --git a/src/Grammar.hs b/src/Grammar.hs index 4e15390..86f5448 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -146,9 +146,5 @@ statement = letVariable ] - -parseInput :: String -> [Statement] -parseInput input = let res = parse statement "" input in - case res of - Left err -> error (show err) - Right sts -> sts +parseInput :: String -> Either (ParseErrorBundle String Void) [Statement] +parseInput input = parse statement "" input From f08e294bbd3e03e4b40663ca4f389ec21e4b813e Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 27 Nov 2022 22:34:32 +0100 Subject: [PATCH 25/75] Added Errors support --- L-static-analyzer.cabal | 6 +++ package.yaml | 2 + src/Context.hs | 8 ++-- src/Error.hs | 14 ++++--- src/Evaluate.hs | 93 ++++++++++++++++++++++------------------- src/Execute.hs | 26 ++++++------ stack.yaml | 3 +- 7 files changed, 84 insertions(+), 68 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 1a8fdd5..d9e0e10 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -39,10 +39,12 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , composition-prelude , containers , megaparsec , mtl , parser-combinators + , transformers default-language: Haskell2010 executable L-static-analyzer-exe @@ -55,10 +57,12 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , composition-prelude , containers , megaparsec , mtl , parser-combinators + , transformers default-language: Haskell2010 test-suite L-static-analyzer-test @@ -76,6 +80,7 @@ test-suite L-static-analyzer-test , HUnit-approx , L-static-analyzer , base >=4.7 && <5 + , composition-prelude , containers , hedgehog , hspec @@ -87,4 +92,5 @@ test-suite L-static-analyzer-test , tasty-discover , tasty-hedgehog , tasty-hunit + , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 0648d54..96e244b 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,8 @@ description: Please see the README on GitHub at = 4.7 && < 5 - containers +- transformers +- composition-prelude - megaparsec - parser-combinators - mtl diff --git a/src/Context.hs b/src/Context.hs index 4193894..02031dc 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -39,7 +39,7 @@ getVar cxt var = let mp = context . vars $ cxt in Map.lookup var mp -setVar :: Context -> String -> Int -> Context -setVar cxt name val = - let mp = context . vars $ cxt - in cxt {vars = VarContext $ Map.insert name val mp} +setVar :: String -> Int -> Context -> Context +setVar name val ctx = + let mp = context . vars $ ctx + in ctx {vars = VarContext $ Map.insert name val mp} diff --git a/src/Error.hs b/src/Error.hs index c0ae991..4f06bcc 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -1,8 +1,10 @@ module Error where -import Statement(Expression) +import Text.Megaparsec.Error (ParseErrorBundle) +import Data.Void (Void) -data RuntimeError = EvalError Expression - | VarNameError String - | UnsupportedError - | InvalidInputError String - deriving (Show, Eq) +type ParsecError = ParseErrorBundle String Void + +data RuntimeError = ParserError ParsecError + | VarNotFound String + | FunctionNotFound String + | UnexpectedEOF \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 3b10ea1..fe6a598 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,38 +1,48 @@ -{-# LANGUAGE BangPatterns #-} - module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where import Context (Context (..), InputSource (..), getVar, setVar) -import Control.Monad.State.Lazy -import Data.Maybe (fromMaybe) -import Statement (Expression (..), Operations (..), Statement (..)) +import Control.Composition +import Control.Monad.State +import Error (RuntimeError (..)) import Grammar (number) -import Text.Megaparsec (runParser, eof) +import Statement (Expression (..), Operations (..), Statement (..)) +import Text.Megaparsec (eof, runParser) -evaluateExpression :: Expression -> Context -> Int -evaluateExpression (Const x) _ = x -evaluateExpression (VariableName name) ctx = fromMaybe undefined (getVar ctx name) -evaluateExpression (FunctionCall _ _) _ = undefined -evaluateExpression (Application op) ctx = evaluateOp op ctx +evaluateExpression :: Expression -> StateT Context (Either RuntimeError) Int +evaluateExpression (Const x) = return x +evaluateExpression (VariableName name) = do + ctx <- get + case getVar ctx name of + Just x -> return x + _ -> lift $ Left $ VarNotFound name +evaluateExpression (FunctionCall name _) = lift $ Left $ FunctionNotFound name +evaluateExpression (Application op') = do + let (x, y, op) = unpack op' + x' <- evaluateExpression x + y' <- evaluateExpression y + return $ op x' y' where - evaluateOp :: Operations -> Context -> Int - evaluateOp (Addition lft rgt) ctx = evaluateExpression lft ctx + evaluateExpression rgt ctx - evaluateOp (Subtraction lft rgt) ctx = evaluateExpression lft ctx - evaluateExpression rgt ctx - evaluateOp (Division lft rgt) ctx = evaluateExpression lft ctx `div` evaluateExpression rgt ctx - evaluateOp (Multiplication lft rgt) ctx = evaluateExpression lft ctx * evaluateExpression rgt ctx - evaluateOp (Modulo lft rgt) ctx = evaluateExpression lft ctx `mod` evaluateExpression rgt ctx - evaluateOp (Equals lft rgt) ctx = fromBool $ evaluateExpression lft ctx == evaluateExpression rgt ctx - evaluateOp (NotEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx /= evaluateExpression rgt ctx - evaluateOp (Greater lft rgt) ctx = fromBool $ evaluateExpression lft ctx > evaluateExpression rgt ctx - evaluateOp (GreaterOrEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx >= evaluateExpression rgt ctx - evaluateOp (Less lft rgt) ctx = fromBool $ evaluateExpression lft ctx < evaluateExpression rgt ctx - evaluateOp (LessOrEquals lft rgt) ctx = fromBool $ evaluateExpression lft ctx <= evaluateExpression rgt ctx - evaluateOp (LazyAnd lft rgt) ctx = case evaluateExpression lft ctx of - 0 -> 0 - _ -> boolToInt $ evaluateExpression rgt ctx - evaluateOp (LazyOr lft rgt) ctx = case evaluateExpression lft ctx of - 0 -> boolToInt $ evaluateExpression rgt ctx - _ -> 1 + -- FIXME: fix that crappy design + unpack :: Operations -> (Expression, Expression, Int -> Int -> Int) + unpack (Addition lft rgt) = (lft, rgt, (+)) + unpack (Subtraction lft rgt) = (lft, rgt, (-)) + unpack (Division lft rgt) = (lft, rgt, div) + unpack (Multiplication lft rgt) = (lft, rgt, (*)) + unpack (Modulo lft rgt) = (lft, rgt, mod) + unpack (Equals lft rgt) = (lft, rgt, fromBool .* (==)) + unpack (NotEquals lft rgt) = (lft, rgt, fromBool .* (/=)) + unpack (Greater lft rgt) = (lft, rgt, fromBool .* (>)) + unpack (GreaterOrEquals lft rgt) = (lft, rgt, fromBool .* (>=)) + unpack (Less lft rgt) = (lft, rgt, fromBool .* (<)) + unpack (LessOrEquals lft rgt) = (lft, rgt, fromBool .* (<=)) + unpack (LazyAnd lft rgt) = (lft, rgt, lazyAnd) + unpack (LazyOr lft rgt) = (lft, rgt, lazyOr) + + lazyAnd :: Int -> Int -> Int + lazyAnd lft rgt = if lft == 0 then 0 else boolToInt rgt + + lazyOr :: Int -> Int -> Int + lazyOr lft rgt = if lft /= 0 then 1 else boolToInt rgt fromBool :: Bool -> Int fromBool True = 1 @@ -46,39 +56,36 @@ toBool :: Int -> Bool toBool 0 = False toBool _ = True -evaluateOneStatement :: Statement -> State Context () +evaluateOneStatement :: Statement -> StateT Context (Either RuntimeError) () evaluateOneStatement (Let name value) = do - ctx <- get - let !value' = evaluateExpression value ctx - put $ setVar ctx name value' + value' <- evaluateExpression value + modify (setVar name value') evaluateOneStatement Skip = pure () evaluateOneStatement (While expression statements) = do - ctx <- get - let !value = evaluateExpression expression ctx + value <- evaluateExpression expression if toBool value then return () else evaluateStatements statements evaluateOneStatement (If expression trueStatements falseStatements) = do - ctx <- get - let !value = evaluateExpression expression ctx + value <- evaluateExpression expression if toBool value then evaluateStatements trueStatements else evaluateStatements falseStatements evaluateOneStatement (FunctionCallStatement name args) = pure () evaluateOneStatement (Write expr) = do + value <- evaluateExpression expr ctx <- get - let !value = evaluateExpression expr ctx - put ctx {output = output ctx ++ [show value]} + put $ ctx {output = output ctx ++ [show value]} evaluateOneStatement (Read val) = do ctx <- get case (inputLines . input) ctx of - [] -> undefined -- FIXME + [] -> lift $ Left UnexpectedEOF (x : xs) -> do case runParser (number <* eof) (fileName $ input ctx) x of - Left _ -> undefined -- FIXME - Right value -> put (setVar ctx val value) {input = (input ctx) {inputLines = xs}} + Left e -> lift $ Left $ ParserError e + Right value -> put (setVar val value ctx) {input = (input ctx) {inputLines = xs}} -evaluateStatements :: [Statement] -> State Context () +evaluateStatements :: [Statement] -> StateT Context (Either RuntimeError) () evaluateStatements [] = pure () evaluateStatements (x : xs) = do evaluateOneStatement x diff --git a/src/Execute.hs b/src/Execute.hs index e3c8026..cc888a6 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,19 +1,17 @@ -module Execute(run) where +module Execute (run) where import Context (Context (..)) -import Control.Monad.State.Lazy +import Control.Monad.State +import Error (RuntimeError (..)) import Evaluate (evaluateStatements) import Grammar (statement) -import Text.Megaparsec (runParser, eof) -import Text.Megaparsec.Error (ParseErrorBundle) -import Data.Void (Void) +import Text.Megaparsec (eof, runParser) -run :: String -> [String] -> State Context (Maybe (ParseErrorBundle String Void)) -run _ [] = return Nothing -run fileName (x : xs) = - case runParser (statement <* eof) fileName x of - Left err -> return $ Just err - Right statements -> - do - evaluateStatements statements - run fileName xs +run :: String -> [String] -> StateT Context (Either RuntimeError) () +run _ [] = return () +run fileName (x : xs) = do + case runParser (statement <* eof) fileName x of + Left err -> lift $ Left $ ParserError err + Right statements -> do + evaluateStatements statements + run fileName xs diff --git a/stack.yaml b/stack.yaml index 29293f3..47eb1c5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,8 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +extra-deps: + - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 # Override default flag values for local packages and extra-deps # flags: {} From 2dfbc59f4d536922abf4d6abdc9231718aa84a3f Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 28 Nov 2022 16:27:18 +0100 Subject: [PATCH 26/75] style fix --- L-static-analyzer.cabal | 4 +- app/Main.hs | 44 +++------------ package.yaml | 1 + src/Console.hs | 55 +++++++++++++++++++ ...{CommandLineParser.hs => ConsoleParser.hs} | 11 ++-- src/Execute.hs | 5 +- src/Grammar.hs | 2 +- 7 files changed, 77 insertions(+), 45 deletions(-) create mode 100644 src/Console.hs rename src/{CommandLineParser.hs => ConsoleParser.hs} (87%) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index b679230..b56e261 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -25,7 +25,8 @@ source-repository head library exposed-modules: - CommandLineParser + Console + ConsoleParser Context Error Evaluate @@ -43,6 +44,7 @@ library , megaparsec , optparse-applicative , parser-combinators + , transformers default-language: Haskell2010 executable L-static-analyzer-exe diff --git a/app/Main.hs b/app/Main.hs index e4243f4..552791d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,10 @@ module Main where import Options.Applicative -import CommandLineParser (Action(..), actionParser, getInput, getVarContext, runInterpreter, Input(..)) import Grammar (parseInput) -import Context (emptyContext, Context(..)) -import Execute (execute) -import Control.Monad (when) -import System.IO +import Console (runLoop, readEvalWriteLoop) +import ConsoleParser (Action(..), Input(..), actionParser, getInput, getVarContext) +import Context (Context(vars), emptyContext) -- Программа парсит аргументы командной строки при помощи execParser, -- а потом запускает функцию runAction (логику приложения) @@ -22,36 +20,12 @@ main = do ) runAction :: Action -> IO () -runAction (Action input@(FileInput _) context) = do +runAction (Action input@(FileInput _) varContext) = do i <- getInput input - let parsed = parseInput i - case parsed of - Left err -> print err - Right sts -> let varContext = getVarContext context in - runInterpreter varContext sts + let context = emptyContext { Context.vars = getVarContext varContext} + runLoop context (lines i) -- выход: q --- TODO: STYLE FIX!!! -runAction (Action Interactive context) = interpret $ emptyContext { Context.vars = getVarContext context } - where - interpret :: Context -> IO () - interpret cxt = do - line <- prompt "L: " - when (line /= "q") $ - let parsed = parseInput line in - case parsed of - Left err -> print err >> interpret cxt - Right sts -> do - newcxt <- execute cxt sts - case newcxt of - Context { Context.error = Just err } -> do - print err - interpret $ newcxt { Context.error = Nothing} - _ -> do - interpret newcxt - -prompt :: String -> IO String -prompt text = do - putStr text - hFlush stdout - getLine \ No newline at end of file +runAction (Action Interactive varContext) = + let context = emptyContext { Context.vars = getVarContext varContext} in + readEvalWriteLoop context diff --git a/package.yaml b/package.yaml index 353469d..7d43144 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,7 @@ library: dependencies: - containers - optparse-applicative + - transformers executables: L-static-analyzer-exe: diff --git a/src/Console.hs b/src/Console.hs new file mode 100644 index 0000000..3990f9a --- /dev/null +++ b/src/Console.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE PatternSynonyms #-} +module Console where + +import Statement (Statement) +import Context (Context(..), pattern ErrorContext) +import Execute (run, execute) +import Grammar (parseInput) +import Control.Monad.Trans.Maybe ( MaybeT(runMaybeT) ) +import System.IO ( hFlush, stdout ) +import Control.Monad (when) +import Control.Applicative ( Alternative(empty) ) +import Error (RuntimeError) +import Control.Monad.Trans.Class ( MonadTrans(lift) ) + + +runFromString :: Context -> String -> IO () +runFromString context str = do + parsed <- runMaybeT $ safeParseInput str + case parsed of + Nothing -> pure () + Just sts -> run context sts + +execFromString :: Context -> String -> IO Context +execFromString context str = do + parsed <- runMaybeT $ safeParseInput str + maybe (pure context) (execute context) parsed + +safeParseInput :: String -> MaybeT IO [Statement] +safeParseInput str = do + case parseInput str of + Left err -> lift (print err) >> empty + Right sts -> return sts + +-- TODO: print expression results +readEvalWriteLoop :: Context -> IO () +readEvalWriteLoop context = do + input <- prompt "L: " + when (input /= "q") $ execFromString context input >>= unsetError >>= readEvalWriteLoop + +runLoop :: Context -> [String] -> IO () +runLoop c@ErrorContext _ = print $ Context.error c +runLoop c (x:xs) = execFromString c x >>= runLoop' xs where + runLoop' sts cxt = runLoop cxt sts +runLoop _ [] = pure () + +unsetError :: Context -> IO Context +unsetError context = maybe (pure context) f (Context.error context) where + f :: RuntimeError -> IO Context + f err = print err >> pure (context { Context.error = Nothing }) + +prompt :: String -> IO String +prompt text = do + putStr text + hFlush stdout + getLine diff --git a/src/CommandLineParser.hs b/src/ConsoleParser.hs similarity index 87% rename from src/CommandLineParser.hs rename to src/ConsoleParser.hs index a63e971..9af76fc 100644 --- a/src/CommandLineParser.hs +++ b/src/ConsoleParser.hs @@ -1,4 +1,4 @@ -module CommandLineParser where +module ConsoleParser where import qualified Options.Applicative as Optparse import qualified Text.Megaparsec as Megaparsec @@ -35,13 +35,14 @@ inputParser = FileInput <$> Optparse.strOption varsParser :: Optparse.Parser [String] varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar "VARS..." -varArg :: LParser.Parser (String, Int) -varArg = (,) - <$> (LParser.lexeme LParser.name "Variable name") <*> (LParser.symbol "=" *> LParser.lexeme LParser.decimal "const value" ) "Variable argument" +varArgParser :: LParser.Parser (String, Int) +varArgParser = (,) + <$> (LParser.lexeme LParser.name "Variable name") + <*> (LParser.symbol "=" *> LParser.lexeme LParser.decimal "const value" ) "Variable argument" getVarContext :: [String] -> VarContext getVarContext (x:xs) = - let res = Megaparsec.parse varArg "" x in + let res = Megaparsec.parse varArgParser "" x in case res of Left err -> Prelude.error $ show err Right (var, val) -> setVarContext (getVarContext xs) var val diff --git a/src/Execute.hs b/src/Execute.hs index 91df94b..2f19492 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -6,6 +6,7 @@ import Error (RuntimeError(UnsupportedError, InvalidInputError)) import Evaluate ( evaluate ) import Control.Monad (foldM) import Text.Read (readMaybe) +import Control.Applicative (Alternative(empty)) executeStatement :: Context -> Statement -> IO Context @@ -32,6 +33,4 @@ execute = foldM executeStatement run :: Context -> [Statement] -> IO () run cxt sts = do res <- execute cxt sts - case Context.error res of - Nothing -> putStrLn "Success!" - Just err -> putStrLn $ "Error: " ++ show err + maybe empty print (Context.error res) diff --git a/src/Grammar.hs b/src/Grammar.hs index 86f5448..1411973 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -147,4 +147,4 @@ statement = ] parseInput :: String -> Either (ParseErrorBundle String Void) [Statement] -parseInput input = parse statement "" input +parseInput = parse statement "" From 4fcd710ded01c69852f9809e1d27a4bfad692481 Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 28 Nov 2022 17:56:23 +0100 Subject: [PATCH 27/75] somehow ot works --- app/Main.hs | 22 +++++++----------- src/Context.hs | 11 ++++----- src/Error.hs | 3 ++- src/Evaluate.hs | 62 +++++++++++++++++++++++++++++-------------------- src/Execute.hs | 14 ++++++----- 5 files changed, 60 insertions(+), 52 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 50867aa..6d5ca46 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,21 +1,15 @@ module Main (main) where import Statement(Statement(Write, Skip, Read), Expression(Const, VariableName)) ---import Execute (run) ---import Context (empty) +import Execute (run) +import Context (newContext) +import Control.Monad.State main :: IO () main = do - putStrLn "Hello World!" --- let writeConst = Write (Const 1) --- let writeVar = Write (VariableName "var") --- let skip = Skip --- let readVar = Read "var" --- --- print readVar --- run singleton [readVar, writeVar] --- run singleton [readVar] --- run singleton [writeVar] --- run singleton [writeConst] --- run singleton [skip] + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let skip = Skip + let readVar = Read "var" + evalStateT (run ["read var", "write var"]) newContext diff --git a/src/Context.hs b/src/Context.hs index 02031dc..8557be8 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -3,6 +3,7 @@ module Context(Context(..), InputSource(..), newContext, getVar, setVar) where import qualified Data.Map as Map +import Error (RuntimeError) data FunContext = FunContext deriving (Show, Eq) @@ -16,8 +17,7 @@ emptyVarContext = VarContext {context = Map.empty} data Context = Context { funs :: FunContext, vars :: VarContext, - input :: InputSource, - output :: [String] + error :: Maybe RuntimeError } deriving (Show) @@ -25,13 +25,12 @@ instance Eq Context where (==) :: Context -> Context -> Bool (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 -newContext :: InputSource -> Context -newContext i = +newContext :: Context +newContext = Context { funs = FunContext, vars = emptyVarContext, - input = i, - output = [] + Context.error = Nothing } getVar :: Context -> String -> Maybe Int diff --git a/src/Error.hs b/src/Error.hs index 4f06bcc..c4a51d3 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -7,4 +7,5 @@ type ParsecError = ParseErrorBundle String Void data RuntimeError = ParserError ParsecError | VarNotFound String | FunctionNotFound String - | UnexpectedEOF \ No newline at end of file + | UnexpectedEOF + deriving (Show, Eq) \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index fe6a598..ec3336a 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -7,20 +7,28 @@ import Error (RuntimeError (..)) import Grammar (number) import Statement (Expression (..), Operations (..), Statement (..)) import Text.Megaparsec (eof, runParser) +import Text.Read (readMaybe) -evaluateExpression :: Expression -> StateT Context (Either RuntimeError) Int -evaluateExpression (Const x) = return x +evaluateExpression :: Expression -> StateT Context IO (Maybe Int) +evaluateExpression (Const x) = return $ Just x evaluateExpression (VariableName name) = do ctx <- get case getVar ctx name of - Just x -> return x - _ -> lift $ Left $ VarNotFound name -evaluateExpression (FunctionCall name _) = lift $ Left $ FunctionNotFound name + x@(Just _) -> return x + Nothing -> do + put (ctx { Context.error = Just $ VarNotFound name }) + return Nothing +evaluateExpression (FunctionCall name _) = do + ctx <- get + put $ ctx { Context.error = Just $ FunctionNotFound name } + return Nothing evaluateExpression (Application op') = do let (x, y, op) = unpack op' x' <- evaluateExpression x y' <- evaluateExpression y - return $ op x' y' + case (x', y') of + (Just val_x, Just val_y) -> return $ Just $ op val_x val_y + (_, _) -> return Nothing where -- FIXME: fix that crappy design unpack :: Operations -> (Expression, Expression, Int -> Int -> Int) @@ -56,36 +64,40 @@ toBool :: Int -> Bool toBool 0 = False toBool _ = True -evaluateOneStatement :: Statement -> StateT Context (Either RuntimeError) () +evaluateOneStatement :: Statement -> StateT Context IO () evaluateOneStatement (Let name value) = do value' <- evaluateExpression value - modify (setVar name value') + case value' of + Just val -> modify (setVar name val) + Nothing -> pure () evaluateOneStatement Skip = pure () evaluateOneStatement (While expression statements) = do value <- evaluateExpression expression - if toBool value - then return () - else evaluateStatements statements + case value of + Just val | toBool val -> pure () + | otherwise -> evaluateStatements statements + Nothing -> pure () evaluateOneStatement (If expression trueStatements falseStatements) = do value <- evaluateExpression expression - if toBool value - then evaluateStatements trueStatements - else evaluateStatements falseStatements -evaluateOneStatement (FunctionCallStatement name args) = pure () + case value of + Just val | toBool val -> evaluateStatements trueStatements + | otherwise -> evaluateStatements falseStatements + Nothing -> pure () +evaluateOneStatement (FunctionCallStatement _ _) = pure () evaluateOneStatement (Write expr) = do value <- evaluateExpression expr + case value of + Just val -> lift $ print val + Nothing -> pure () + +evaluateOneStatement (Read var) = do ctx <- get - put $ ctx {output = output ctx ++ [show value]} -evaluateOneStatement (Read val) = do - ctx <- get - case (inputLines . input) ctx of - [] -> lift $ Left UnexpectedEOF - (x : xs) -> do - case runParser (number <* eof) (fileName $ input ctx) x of - Left e -> lift $ Left $ ParserError e - Right value -> put (setVar val value ctx) {input = (input ctx) {inputLines = xs}} + inp <- lift getLine + case readMaybe inp :: Maybe Int of + Nothing -> put $ ctx { Context.error = Nothing } + Just val -> put $ setVar var val ctx -evaluateStatements :: [Statement] -> StateT Context (Either RuntimeError) () +evaluateStatements :: [Statement] -> StateT Context IO () evaluateStatements [] = pure () evaluateStatements (x : xs) = do evaluateOneStatement x diff --git a/src/Execute.hs b/src/Execute.hs index cc888a6..d2d1b21 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -7,11 +7,13 @@ import Evaluate (evaluateStatements) import Grammar (statement) import Text.Megaparsec (eof, runParser) -run :: String -> [String] -> StateT Context (Either RuntimeError) () -run _ [] = return () -run fileName (x : xs) = do - case runParser (statement <* eof) fileName x of - Left err -> lift $ Left $ ParserError err +run :: [String] -> StateT Context IO () +run [] = return () +run (x : xs) = do + cxt <- get + guard ( Context.error cxt == Nothing ) + case runParser (statement <* eof) "" x of + Left err -> put $ cxt { Context.error = Just $ ParserError err } Right statements -> do evaluateStatements statements - run fileName xs + run xs From dce341af7dccecf6e9367c2d591acfe5a9df742e Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 5 Dec 2022 12:53:00 +0100 Subject: [PATCH 28/75] cabal --- L-static-analyzer.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index b56e261..bc9d87e 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -68,6 +68,7 @@ test-suite L-static-analyzer-test main-is: Test.hs other-modules: Test.Console + Test.ConsoleParser Test.Parsers Paths_L_static_analyzer hs-source-dirs: From df9cc4928b8f99bf0e1fd6808fa1659cbff359ae Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 5 Dec 2022 14:59:29 +0100 Subject: [PATCH 29/75] fix style --- L-static-analyzer.cabal | 8 +- app/Main.hs | 12 +- package.yaml | 2 + src/Console.hs | 62 +++---- src/ConsoleParser.hs | 10 +- src/Context.hs | 83 +++++---- src/Error.hs | 16 +- src/Evaluate.hs | 120 ++++++++++++- src/Execute.hs | 54 +++--- src/Grammar.hs | 19 +-- stack.yaml | 3 + test/Test/{Console.hs => ConsoleParser.hs} | 11 +- test/Test/Parsers.hs | 189 --------------------- 13 files changed, 235 insertions(+), 354 deletions(-) rename test/Test/{Console.hs => ConsoleParser.hs} (73%) delete mode 100644 test/Test/Parsers.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index bc9d87e..d517246 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -40,8 +40,10 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , composition-prelude , containers , megaparsec + , mtl , optparse-applicative , parser-combinators , transformers @@ -57,8 +59,10 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , composition-prelude , containers , megaparsec + , mtl , optparse-applicative , parser-combinators default-language: Haskell2010 @@ -67,9 +71,7 @@ test-suite L-static-analyzer-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: - Test.Console Test.ConsoleParser - Test.Parsers Paths_L_static_analyzer hs-source-dirs: test @@ -79,11 +81,13 @@ test-suite L-static-analyzer-test , HUnit-approx , L-static-analyzer , base >=4.7 && <5 + , composition-prelude , containers , hedgehog , hspec , hspec-megaparsec , megaparsec + , mtl , parser-combinators , tasty , tasty-discover diff --git a/app/Main.hs b/app/Main.hs index 552791d..2abfff7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,10 @@ module Main where import Options.Applicative -import Grammar (parseInput) import Console (runLoop, readEvalWriteLoop) import ConsoleParser (Action(..), Input(..), actionParser, getInput, getVarContext) -import Context (Context(vars), emptyContext) +import Context (Context(vars), newContext) +import Control.Monad.State -- Программа парсит аргументы командной строки при помощи execParser, -- а потом запускает функцию runAction (логику приложения) @@ -22,10 +22,10 @@ main = do runAction :: Action -> IO () runAction (Action input@(FileInput _) varContext) = do i <- getInput input - let context = emptyContext { Context.vars = getVarContext varContext} - runLoop context (lines i) + let context = newContext { Context.vars = getVarContext varContext} + evalStateT (runLoop $ lines i) context -- выход: q runAction (Action Interactive varContext) = - let context = emptyContext { Context.vars = getVarContext varContext} in - readEvalWriteLoop context + let context = newContext { Context.vars = getVarContext varContext} in + evalStateT readEvalWriteLoop context diff --git a/package.yaml b/package.yaml index 7d43144..b9b2816 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,8 @@ dependencies: - containers - megaparsec - parser-combinators +- composition-prelude +- mtl ghc-options: - -Wall diff --git a/src/Console.hs b/src/Console.hs index 3990f9a..1a0fa55 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -1,52 +1,30 @@ -{-# LANGUAGE PatternSynonyms #-} module Console where -import Statement (Statement) -import Context (Context(..), pattern ErrorContext) -import Execute (run, execute) -import Grammar (parseInput) -import Control.Monad.Trans.Maybe ( MaybeT(runMaybeT) ) +import Context (Context(..)) +import Execute (execute, run) import System.IO ( hFlush, stdout ) import Control.Monad (when) -import Control.Applicative ( Alternative(empty) ) -import Error (RuntimeError) -import Control.Monad.Trans.Class ( MonadTrans(lift) ) - - -runFromString :: Context -> String -> IO () -runFromString context str = do - parsed <- runMaybeT $ safeParseInput str - case parsed of - Nothing -> pure () - Just sts -> run context sts - -execFromString :: Context -> String -> IO Context -execFromString context str = do - parsed <- runMaybeT $ safeParseInput str - maybe (pure context) (execute context) parsed -safeParseInput :: String -> MaybeT IO [Statement] -safeParseInput str = do - case parseInput str of - Left err -> lift (print err) >> empty - Right sts -> return sts +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.State -- TODO: print expression results -readEvalWriteLoop :: Context -> IO () -readEvalWriteLoop context = do - input <- prompt "L: " - when (input /= "q") $ execFromString context input >>= unsetError >>= readEvalWriteLoop - -runLoop :: Context -> [String] -> IO () -runLoop c@ErrorContext _ = print $ Context.error c -runLoop c (x:xs) = execFromString c x >>= runLoop' xs where - runLoop' sts cxt = runLoop cxt sts -runLoop _ [] = pure () - -unsetError :: Context -> IO Context -unsetError context = maybe (pure context) f (Context.error context) where - f :: RuntimeError -> IO Context - f err = print err >> pure (context { Context.error = Nothing }) +readEvalWriteLoop :: StateT Context IO () +readEvalWriteLoop = do + input <- lift $ prompt "L: " + when (input /= "q") $ execute input >> unsetError >> readEvalWriteLoop + +runLoop :: [String] -> StateT Context IO () +runLoop input = do + run input + context <- get + maybe (pure ()) (lift . print) (Context.error context) + +unsetError :: StateT Context IO () +unsetError = do + context <- get + let f err = lift (print err) >> put (context { Context.error = Nothing }) + maybe (pure ()) f (Context.error context) prompt :: String -> IO String prompt text = do diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index 9af76fc..14925ec 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -4,9 +4,7 @@ import qualified Options.Applicative as Optparse import qualified Text.Megaparsec as Megaparsec import qualified Grammar as LParser import Text.Megaparsec ( (), (<|>) ) -import Context (VarContext, Context(..), setVarContext, emptyContext, emptyVarContext) -import Statement -import Execute (run) +import Context (VarContext, setVarContext, emptyVarContext) -- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом data Action = Action @@ -38,19 +36,17 @@ varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar " varArgParser :: LParser.Parser (String, Int) varArgParser = (,) <$> (LParser.lexeme LParser.name "Variable name") - <*> (LParser.symbol "=" *> LParser.lexeme LParser.decimal "const value" ) "Variable argument" + <*> (LParser.symbol "=" *> LParser.lexeme LParser.number "const value" ) "Variable argument" getVarContext :: [String] -> VarContext getVarContext (x:xs) = let res = Megaparsec.parse varArgParser "" x in case res of Left err -> Prelude.error $ show err - Right (var, val) -> setVarContext (getVarContext xs) var val + Right (var, val) -> setVarContext var val (getVarContext xs) getVarContext [] = emptyVarContext getInput :: Input -> IO String getInput (FileInput path) = readFile path getInput Interactive = getLine -runInterpreter :: VarContext -> [Statement] -> IO () -runInterpreter varcxt = run $ emptyContext { Context.vars = varcxt } diff --git a/src/Context.hs b/src/Context.hs index b9e5bd9..979b9e3 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,60 +1,53 @@ -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE InstanceSigs #-} -module Context where -import Error ( RuntimeError(VarNameError) ) +{-# LANGUAGE PatternSynonyms #-} + +module Context(Context(..), InputSource(..), newContext, getVar, setVar, setVarContext, VarContext, emptyVarContext, pattern ErrorContext) where + import qualified Data.Map as Map +import Error (RuntimeError) data FunContext = FunContext deriving (Show, Eq) -data VarContext = VarContext { context :: Map.Map String Int } deriving (Show, Eq) +newtype VarContext = VarContext {context :: Map.Map String Int} deriving (Show, Eq) + +data InputSource = InputSource {fileName :: String, inputLines :: [String]} deriving (Show) emptyVarContext :: VarContext -emptyVarContext = VarContext { context = Map.empty } +emptyVarContext = VarContext {context = Map.empty} -setVarContext :: VarContext -> String -> Int -> VarContext -setVarContext cxt var val = VarContext $ Map.insert var val $ context cxt +setVarContext :: String -> Int -> VarContext -> VarContext +setVarContext name val ctx = + let mp = context ctx in + VarContext $ Map.insert name val mp -data Context = Context - { funs :: FunContext - , vars :: VarContext - , error :: Maybe RuntimeError - , getNextLine :: IO String - , putLine :: String -> IO () - } +data Context = Context + { funs :: FunContext, + vars :: VarContext, + error :: Maybe RuntimeError + } + deriving (Show) -instance Show Context where - show :: Context -> String - show cxt = "Functions: " ++ show (funs cxt) ++ "\nVariables: " ++ show (vars cxt) ++ "\nError: " ++ show (Context.error cxt) +pattern ErrorContext :: Context +pattern ErrorContext <- Context { Context.error = (Just _) } instance Eq Context where - (==) :: Context -> Context -> Bool - (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 && Context.error c1 == Context.error c2 - -emptyContext :: Context -emptyContext = Context - { funs = FunContext - , vars = emptyVarContext - , Context.error = Nothing - , getNextLine = getLine - , putLine = putStrLn + (==) :: Context -> Context -> Bool + (==) c1 c2 = funs c1 == funs c2 && vars c1 == vars c2 + +newContext :: Context +newContext = + Context + { funs = FunContext, + vars = emptyVarContext, + Context.error = Nothing } -pattern ErrorContext :: Context -pattern ErrorContext <- Context { Context.error = (Just _) } +getVar :: Context -> String -> Maybe Int +getVar cxt var = + let mp = context . vars $ cxt + in Map.lookup var mp -getVar :: Context -> String -> (IO Context, Maybe Int) -getVar cxt var = - let mp = context . vars $ cxt in - let x = Map.lookup var mp in - (case x of - Nothing -> setError cxt $ VarNameError var - Just _ -> pure cxt - , x) - -setVar :: Context -> String -> Int -> Context -setVar cxt name val = - let mp = context . vars $ cxt in - cxt { vars = VarContext $ Map.insert name val mp } - -setError :: Context -> RuntimeError -> IO Context -setError cxt err = pure $ cxt { Context.error = Just err } +setVar :: String -> Int -> Context -> Context +setVar name val ctx = + let mp = context . vars $ ctx + in ctx {vars = VarContext $ Map.insert name val mp} diff --git a/src/Error.hs b/src/Error.hs index c0ae991..cfd47bd 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -1,8 +1,12 @@ module Error where -import Statement(Expression) +import Text.Megaparsec.Error (ParseErrorBundle) +import Data.Void (Void) -data RuntimeError = EvalError Expression - | VarNameError String - | UnsupportedError - | InvalidInputError String - deriving (Show, Eq) +type ParsecError = ParseErrorBundle String Void + +data RuntimeError = ParserError ParsecError + | VarNotFound String + | FunctionNotFound String + | UnexpectedEOF + | InvalidInput String + deriving (Show, Eq) \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 3e9f566..76d54a9 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,12 +1,114 @@ -module Evaluate where -import Statement (Expression (Const, FunctionCall, VariableName, Application)) -import Context ( setError, Context(), getVar ) -import Error ( RuntimeError(UnsupportedError) ) +module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where +import Context (Context (..), getVar, setVar) +import Control.Composition ((.*)) +import Control.Monad.State ( MonadTrans(lift), StateT, MonadState(put, get), modify ) +import Error (RuntimeError (..)) +import Statement (Expression (..), Operations (..), Statement (..)) +import Text.Read (readMaybe) -evaluate :: Context -> Expression -> (IO Context, Maybe Int) -evaluate cxt (Const x) = (pure cxt, Just x) -evaluate cxt (VariableName var) = getVar cxt var -evaluate cxt (FunctionCall _ _) = (setError cxt UnsupportedError, Nothing) -- TODO -evaluate cxt (Application _) = (setError cxt UnsupportedError, Nothing) -- TODO +evaluateExpression :: Expression -> StateT Context IO (Maybe Int) + +evaluateExpression (Const x) = return $ Just x + +evaluateExpression (VariableName name) = do + ctx <- get + case getVar ctx name of + x@(Just _) -> return x + Nothing -> do + put (ctx { Context.error = Just $ VarNotFound name }) + return Nothing + +evaluateExpression (FunctionCall name _) = do + ctx <- get + put $ ctx { Context.error = Just $ FunctionNotFound name } + return Nothing + +evaluateExpression (Application op') = do + let (x, y, op) = unpack op' + x' <- evaluateExpression x + y' <- evaluateExpression y + case (x', y') of + (Just val_x, Just val_y) -> return $ Just $ op val_x val_y + (_, _) -> return Nothing + where + -- FIXME: fix that crappy design + unpack :: Operations -> (Expression, Expression, Int -> Int -> Int) + unpack (Addition lft rgt) = (lft, rgt, (+)) + unpack (Subtraction lft rgt) = (lft, rgt, (-)) + unpack (Division lft rgt) = (lft, rgt, div) + unpack (Multiplication lft rgt) = (lft, rgt, (*)) + unpack (Modulo lft rgt) = (lft, rgt, mod) + unpack (Equals lft rgt) = (lft, rgt, fromBool .* (==)) + unpack (NotEquals lft rgt) = (lft, rgt, fromBool .* (/=)) + unpack (Greater lft rgt) = (lft, rgt, fromBool .* (>)) + unpack (GreaterOrEquals lft rgt) = (lft, rgt, fromBool .* (>=)) + unpack (Less lft rgt) = (lft, rgt, fromBool .* (<)) + unpack (LessOrEquals lft rgt) = (lft, rgt, fromBool .* (<=)) + unpack (LazyAnd lft rgt) = (lft, rgt, lazyAnd) + unpack (LazyOr lft rgt) = (lft, rgt, lazyOr) + + lazyAnd :: Int -> Int -> Int + lazyAnd lft rgt = if lft == 0 then 0 else boolToInt rgt + + lazyOr :: Int -> Int -> Int + lazyOr lft rgt = if lft /= 0 then 1 else boolToInt rgt + + fromBool :: Bool -> Int + fromBool True = 1 + fromBool False = 0 + + boolToInt :: Int -> Int + boolToInt 0 = 0 + boolToInt _ = 1 + +toBool :: Int -> Bool +toBool 0 = False +toBool _ = True + + +evaluateOneStatement :: Statement -> StateT Context IO () + +evaluateOneStatement (Let name value) = do + value' <- evaluateExpression value + case value' of + Just val -> modify (setVar name val) + Nothing -> pure () + +evaluateOneStatement Skip = pure () + +evaluateOneStatement (While expression statements) = do + value <- evaluateExpression expression + case value of + Just val | toBool val -> pure () + | otherwise -> evaluateStatements statements + Nothing -> pure () + +evaluateOneStatement (If expression trueStatements falseStatements) = do + value <- evaluateExpression expression + case value of + Just val | toBool val -> evaluateStatements trueStatements + | otherwise -> evaluateStatements falseStatements + Nothing -> pure () + +evaluateOneStatement (FunctionCallStatement _ _) = pure () + +evaluateOneStatement (Write expr) = do + value <- evaluateExpression expr + case value of + Just val -> lift $ print val + Nothing -> pure () + +evaluateOneStatement (Read var) = do + ctx <- get + inp <- lift getLine + case readMaybe inp :: Maybe Int of + Nothing -> put $ ctx { Context.error = Just $ InvalidInput inp } + Just val -> put $ setVar var val ctx + +evaluateStatements :: [Statement] -> StateT Context IO () +evaluateStatements [] = pure () +evaluateStatements (x : xs) = do + evaluateOneStatement x + evaluateStatements xs diff --git a/src/Execute.hs b/src/Execute.hs index 2f19492..06f2351 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,36 +1,26 @@ -{-# LANGUAGE PatternSynonyms #-} -module Execute where -import Statement (Statement(Write, Read)) -import Context ( Context(error, putLine, getNextLine), pattern ErrorContext, setVar, setError ) -import Error (RuntimeError(UnsupportedError, InvalidInputError)) -import Evaluate ( evaluate ) -import Control.Monad (foldM) -import Text.Read (readMaybe) -import Control.Applicative (Alternative(empty)) +module Execute (run, execute) where +import Context (Context (..)) +import Control.Monad.State +import Error (RuntimeError (..)) +import Evaluate (evaluateStatements) +import Grammar (statement) +import Text.Megaparsec (eof, parse) +import Data.Maybe (isNothing) +import Text.Megaparsec.Error (ParseErrorBundle) +import Data.Void +import Statement (Statement) -executeStatement :: Context -> Statement -> IO Context -executeStatement c@ErrorContext _ = pure c +parseInput :: String -> Either (ParseErrorBundle String Void) [Statement] +parseInput = parse (statement <* eof) "" -executeStatement cxt (Write expr) = - let (cxt', x) = evaluate cxt expr in - case x of - Nothing -> cxt' - Just res -> putLine cxt (show res) >> cxt' +run :: [String] -> StateT Context IO () +run = foldr ((>>) . execute) (return ()) -executeStatement cxt (Read name) = do - line <- getNextLine cxt - let val = readMaybe line :: Maybe Int - case val of - Nothing -> setError cxt $ InvalidInputError line - Just x -> pure $ setVar cxt name x - -executeStatement cxt _ = setError cxt UnsupportedError -- TODO - -execute :: Context -> [Statement] -> IO Context -execute = foldM executeStatement - -run :: Context -> [Statement] -> IO () -run cxt sts = do - res <- execute cxt sts - maybe empty print (Context.error res) +execute :: String -> StateT Context IO () +execute str = do + context <- get + guard ( isNothing (Context.error context) ) + case parseInput str of + Left err -> put $ context { Context.error = Just $ ParserError err } + Right statements -> evaluateStatements statements diff --git a/src/Grammar.hs b/src/Grammar.hs index 1411973..0ae4b93 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -19,11 +19,11 @@ lexeme = L.lexeme sc symbol :: String -> Parser String symbol = L.symbol sc -decimal :: Parser Int -decimal = L.decimal +number :: Parser Int +number = lexeme L.decimal "number" constValue :: Parser Expression -constValue = Const <$> lexeme decimal "const value" +constValue = Const <$> lexeme L.decimal "const value" name :: Parser String name = (lexeme . try) (p >>= check) @@ -38,10 +38,10 @@ varName = VariableName <$> name funCall :: Parser Expression funCall = do - FunctionCall <$> (lexeme name "Function name") <*> (arguments "arguments") + FunctionCall <$> (lexeme name "Function name") <*> (lexeme . parens) (arguments "arguments") where arguments :: Parser [Expression] - arguments = (:) <$> expression <*> many expression + arguments = expression `sepBy` lexeme (symbol ",") parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") @@ -119,12 +119,12 @@ funCallStatement :: Parser [Statement] funCallStatement = singleton <$> ( FunctionCallStatement - <$> (name "function name") - <*> (arguments "arguments") + <$> (lexeme name "Function name") + <*> (lexeme . parens) (arguments "arguments") ) where arguments :: Parser [Expression] - arguments = (:) <$> expression <*> many expression + arguments = expression `sepBy` lexeme (symbol ",") skip :: Parser [Statement] skip = [Skip] <$ symbol "skip" @@ -145,6 +145,3 @@ statement = try funCallStatement, letVariable ] - -parseInput :: String -> Either (ParseErrorBundle String Void) [Statement] -parseInput = parse statement "" diff --git a/stack.yaml b/stack.yaml index 29293f3..72f7029 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,6 +41,9 @@ packages: # # extra-deps: [] +extra-deps: + - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 + # Override default flag values for local packages and extra-deps # flags: {} diff --git a/test/Test/Console.hs b/test/Test/ConsoleParser.hs similarity index 73% rename from test/Test/Console.hs rename to test/Test/ConsoleParser.hs index 9a9f157..617f8f6 100644 --- a/test/Test/Console.hs +++ b/test/Test/ConsoleParser.hs @@ -1,7 +1,7 @@ -module Test.Console where +module Test.ConsoleParser where import Grammar (Parser) -import CommandLineParser (varArg) +import ConsoleParser (varArgParser) import Test.HUnit import Text.Megaparsec @@ -15,9 +15,10 @@ parseFailed parser line = case parse (parser <* eof) "" line of Left _ -> True Right _ -> False -unit_varParser = do - let success = parseSuccessful varArg - let fail = parseFailed varArg +unit_varArgParser :: IO () +unit_varArgParser = do + let success = parseSuccessful varArgParser + let fail = parseFailed varArgParser assertBool "1" $ success "x=10" ("x", 10) assertBool "3" $ success "x=0" ("x", 0) diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs deleted file mode 100644 index 474d571..0000000 --- a/test/Test/Parsers.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Test.Parsers where - -import Grammar -import Statement -import Test.HUnit -import Text.Megaparsec - -parseSuccessful :: Eq a => Parser a -> String -> a -> Bool -parseSuccessful parser line result = case parse (parser <* eof) "" line of - Left _ -> False - Right a -> a == result - -parseFailed :: Parser a -> String -> Bool -parseFailed parser line = case parse (parser <* eof) "" line of - Left _ -> True - Right _ -> False - -unit_const :: IO () -unit_const = do - let succConst = parseSuccessful constValue - let failConst = parseFailed constValue - - assertBool "const parser failed" $ succConst "1" (Const 1) - assertBool "const parser failed" $ failConst "1.23456" - assertBool "const parser failed" $ succConst "1234567" (Const 1234567) - assertBool "const parser failed" $ failConst "ahahahahh1234" - -unit_var_name :: IO () -unit_var_name = do - let succVar = parseSuccessful varName - let failVar = parseFailed varName - - assertBool "var parser failed" $ failVar "1234abc" - assertBool "var parser failed" $ failVar "" - assertBool "var parser failed" $ succVar "abcd" (VariableName "abcd") - assertBool "var parser failed" $ succVar "a1234" (VariableName "a1234") - - assertBool "bad keywords are banned" $ failVar "while" - assertBool "bad keywords are banned" $ failVar "do" - assertBool "bad keywords are banned" $ failVar "if" - assertBool "bad keywords are banned" $ failVar "then" - assertBool "bad keywords are banned" $ failVar "else" - -unit_expr :: IO () -unit_expr = do - let succExpr = parseSuccessful expression - let failExpr = parseFailed expression - - assertBool "simple expression" $ succExpr "1" (Const 1) - assertBool "simple with parens" $ succExpr "(1)" (Const 1) - assertBool "operations works fine" $ succExpr "1 + 3" (Application $ Addition (Const 1) (Const 3)) - assertBool "precedence works fine" $ - succExpr - "1 * 2 + 3" - ( Application $ - Addition - ( Application $ - Multiplication - (Const 1) - (Const 2) - ) - (Const 3) - ) - - assertBool "fails on unary" $ failExpr "+1" - assertBool "fails on bad expr" $ failExpr "1+2++-" - -unit_let :: IO () -unit_let = do - let success = parseSuccessful letVariable - let fail = parseFailed letVariable - - assertBool "to const" $ success "x := 1" [Let "x" (Const 1)] - assertBool "reassign" $ success "x := x" [Let "x" (VariableName "x")] - assertBool "compicated expression" $ - success - "x := y % 4 + 2 * 3" - [ Let - "x" - ( Application $ - Addition - ( Application $ - Modulo - (VariableName "y") - (Const 4) - ) - ( Application $ - Multiplication - (Const 2) - (Const 3) - ) - ) - ] - - assertBool "assign statement" $ fail "x := while 1 do 2" - --- TODO: uncomment this (see Grammar.hs for details) --- assertBool "assign function call" $ --- success --- "loooooong := function first second third 1 (2 + 3)" --- ( Let --- "loooooong" --- ( FunctionCall --- "function" --- [ VariableName "first" --- , VariableName "second" --- , VariableName "third" --- , Const 1 --- , Application $ Addition (Const 2) (Const 3) --- ] --- ) --- ) - -unit_while :: IO () -unit_while = do - let success = parseSuccessful while - let fail = parseFailed while - - assertBool "simple while" $ success "while 1 do x := x" [While (Const 1) [Let "x" (VariableName "x")]] - assertBool "complicated expression" $ - success - "while 1 + 2 do x := x" - [ While - (Application $ Addition (Const 1) (Const 2)) - [Let "x" (VariableName "x")] - ] - - assertBool "function call" $ - success - "while f 1 do x := x" - [ While - (FunctionCall "f" [Const 1]) - [Let "x" (VariableName "x")] - ] - - assertBool "just while fails" $ fail "while" - assertBool "just while-do failes" $ fail "while do" - assertBool "without statement fail" $ fail "while 1 do" - assertBool "without condition fail" $ fail "while do x := x" - -unit_if :: IO () -unit_if = do - let success = parseSuccessful ifThenElse - let fail = parseFailed ifThenElse - - assertBool "simple if" $ - success - "if 1 then a 1 else a 2" - [ If - (Const 1) - [FunctionCallStatement "a" [Const 1]] - [FunctionCallStatement "a" [Const 2]] - ] - - assertBool "if fails with statement in condition" $ fail "if x := 1 then a 1 else a 2" - -unit_statement :: IO () -unit_statement = do - let success = parseSuccessful statement - let fail = parseFailed statement - - assertBool "function call" $ success "f 1 2 3" [FunctionCallStatement "f" [Const 1, Const 2, Const 3]] - assertBool "read variable" $ success "read x" [Read "x"] - assertBool "read expression fails" $ fail "read x + 2" - assertBool "write variable" $ success "write x" [Write (VariableName "x")] - assertBool "write complex expression" $ - success - "write x + 2 * 3" - [ Write $ - Application $ - Addition - (VariableName "x") - ( Application $ - Multiplication - (Const 2) - (Const 3) - ) - ] - assertBool "skip statement" $ success "skip" [Skip] - assertBool "multiplie statements" $ success "x := a; y := b" [Let "x" $ VariableName "a", Let "y" $ VariableName "b"] - assertBool "while with long body" $ - success - "while 1 do x := a; y := b" - [ While - (Const 1) - [ Let "x" $ VariableName "a", - Let "y" $ VariableName "b" - ] - ] From 7fb52a4175fd6e4d6e71f23a75ca90664620b68e Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 5 Dec 2022 15:17:42 +0100 Subject: [PATCH 30/75] small style fix --- L-static-analyzer.cabal | 1 + app/Main.hs | 10 +++++----- src/Console.hs | 5 ++--- src/ConsoleParser.hs | 5 ----- 4 files changed, 8 insertions(+), 13 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index d517246..91f7d23 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -71,6 +71,7 @@ test-suite L-static-analyzer-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Test.Console Test.ConsoleParser Paths_L_static_analyzer hs-source-dirs: diff --git a/app/Main.hs b/app/Main.hs index 2abfff7..9b590c8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,10 @@ module Main where -import Options.Applicative +import Options.Applicative ( (<**>), fullDesc, header, info, progDesc, execParser, helper ) import Console (runLoop, readEvalWriteLoop) -import ConsoleParser (Action(..), Input(..), actionParser, getInput, getVarContext) +import ConsoleParser (Action(..), Input(..), actionParser, getVarContext) import Context (Context(vars), newContext) -import Control.Monad.State +import Control.Monad.State ( evalStateT ) -- Программа парсит аргументы командной строки при помощи execParser, -- а потом запускает функцию runAction (логику приложения) @@ -20,8 +20,8 @@ main = do ) runAction :: Action -> IO () -runAction (Action input@(FileInput _) varContext) = do - i <- getInput input +runAction (Action (FileInput path) varContext) = do + i <- readFile path let context = newContext { Context.vars = getVarContext varContext} evalStateT (runLoop $ lines i) context diff --git a/src/Console.hs b/src/Console.hs index 1a0fa55..749f100 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -4,9 +4,8 @@ import Context (Context(..)) import Execute (execute, run) import System.IO ( hFlush, stdout ) import Control.Monad (when) - -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.State +import Control.Monad.State ( MonadTrans(lift) ) +import Control.Monad.Trans.State ( StateT, get, put ) -- TODO: print expression results readEvalWriteLoop :: StateT Context IO () diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index 14925ec..57d2746 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -45,8 +45,3 @@ getVarContext (x:xs) = Left err -> Prelude.error $ show err Right (var, val) -> setVarContext var val (getVarContext xs) getVarContext [] = emptyVarContext - -getInput :: Input -> IO String -getInput (FileInput path) = readFile path -getInput Interactive = getLine - From b36a31fbc5bac45094f688765ab32f85a1ae0967 Mon Sep 17 00:00:00 2001 From: khbminus Date: Mon, 5 Dec 2022 16:34:48 +0100 Subject: [PATCH 31/75] CI --- .github/workflows/ci.yml | 16 ++++++++++++++++ L-static-analyzer.cabal | 9 +++------ 2 files changed, 19 insertions(+), 6 deletions(-) create mode 100644 .github/workflows/ci.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..2228cc4 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,16 @@ +on: [ push ] +name: Test run + +jobs: + runhaskell: + name: Tests + runs-on: ubuntu-latest # or macOS-latest, or windows-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2 + with: + ghc-version: '8.10.7' # Exact version of ghc to use + # cabal-version: 'latest'. Omitted, but defaults to 'latest' + enable-stack: true + stack-version: 'latest' + - run: stack test \ No newline at end of file diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 1ab61da..56d3dc2 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -41,7 +41,7 @@ library base >=4.7 && <5 , containers , megaparsec - , parser-combinator + , parser-combinators default-language: Haskell2010 executable L-static-analyzer-exe @@ -71,13 +71,10 @@ test-suite L-static-analyzer-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit - , L-static-analyzer - , base >=4.7 && <5 - , containers - , tasty , HUnit-approx , L-static-analyzer , base >=4.7 && <5 + , containers , hedgehog , hspec , hspec-megaparsec From 94954edfa6cfcd5e6280ca9df3d3cb3ff2323207 Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 5 Dec 2022 21:18:28 +0100 Subject: [PATCH 32/75] add var context parser test --- L-static-analyzer.cabal | 2 +- package.yaml | 1 + src/Context.hs | 2 +- test/Test/ConsoleParser.hs | 20 +++++++++++++++----- 4 files changed, 18 insertions(+), 7 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 91f7d23..ee916cc 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -71,7 +71,6 @@ test-suite L-static-analyzer-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: - Test.Console Test.ConsoleParser Paths_L_static_analyzer hs-source-dirs: @@ -94,4 +93,5 @@ test-suite L-static-analyzer-test , tasty-discover , tasty-hedgehog , tasty-hunit + , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index b9b2816..335b5fa 100644 --- a/package.yaml +++ b/package.yaml @@ -79,3 +79,4 @@ tests: - HUnit - tasty-hunit - tasty + - transformers diff --git a/src/Context.hs b/src/Context.hs index 979b9e3..e3732c0 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,7 +1,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PatternSynonyms #-} -module Context(Context(..), InputSource(..), newContext, getVar, setVar, setVarContext, VarContext, emptyVarContext, pattern ErrorContext) where +module Context where import qualified Data.Map as Map import Error (RuntimeError) diff --git a/test/Test/ConsoleParser.hs b/test/Test/ConsoleParser.hs index 617f8f6..0c8d79c 100644 --- a/test/Test/ConsoleParser.hs +++ b/test/Test/ConsoleParser.hs @@ -1,9 +1,11 @@ module Test.ConsoleParser where import Grammar (Parser) -import ConsoleParser (varArgParser) +import ConsoleParser (varArgParser, getVarContext) import Test.HUnit import Text.Megaparsec +import Context (VarContext(..)) +import qualified Data.Map as Map parseSuccessful :: Eq a => Parser a -> String -> a -> Bool parseSuccessful parser line result = case parse (parser <* eof) "" line of @@ -18,11 +20,19 @@ parseFailed parser line = case parse (parser <* eof) "" line of unit_varArgParser :: IO () unit_varArgParser = do let success = parseSuccessful varArgParser - let fail = parseFailed varArgParser + let failure = parseFailed varArgParser assertBool "1" $ success "x=10" ("x", 10) assertBool "3" $ success "x=0" ("x", 0) - assertBool "4" $ fail "x tr=1" - assertBool "5" $ fail "1tr=5" - assertBool "6" $ fail "x=vr" + assertBool "4" $ failure "x tr=1" + assertBool "5" $ failure "1tr=5" + assertBool "6" $ failure "x=vr" + +varContextComp :: [String] -> [(String, Int)] -> Bool +varContextComp inp cxt = getVarContext inp == VarContext { context = Map.fromList cxt } + +unit_getVarContext :: IO () +unit_getVarContext = do + assertBool "1" $ varContextComp ["var=234", "var2=0"] [("var", 234), ("var2", 0)] + assertBool "2" $ varContextComp ["var=24", "var=0"] [("var", 24)] From 4dbd5ba35b9eda7a9b10d8b82f862275f44f7957 Mon Sep 17 00:00:00 2001 From: khbminus Date: Mon, 5 Dec 2022 21:32:57 +0100 Subject: [PATCH 33/75] More contexty context --- src/Context.hs | 26 ++++++++++++++++---------- src/Statement.hs | 2 ++ 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 8557be8..2c520b0 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,6 +1,6 @@ {-# LANGUAGE InstanceSigs #-} -module Context(Context(..), InputSource(..), newContext, getVar, setVar) where +module Context (Context (..), InputSource (..), newContext, getVar, setVar) where import qualified Data.Map as Map import Error (RuntimeError) @@ -15,8 +15,8 @@ emptyVarContext :: VarContext emptyVarContext = VarContext {context = Map.empty} data Context = Context - { funs :: FunContext, - vars :: VarContext, + { funs :: [FunContext], + vars :: [VarContext], error :: Maybe RuntimeError } deriving (Show) @@ -28,17 +28,23 @@ instance Eq Context where newContext :: Context newContext = Context - { funs = FunContext, - vars = emptyVarContext, + { funs = [FunContext], + vars = [emptyVarContext], Context.error = Nothing } getVar :: Context -> String -> Maybe Int -getVar cxt var = - let mp = context . vars $ cxt - in Map.lookup var mp +getVar ctx var = helper . vars $ ctx + where + helper :: [VarContext] -> Maybe Int + helper [] = Nothing + helper (x : xs) = case Map.lookup var (context x) of + Nothing -> helper xs + j -> j + setVar :: String -> Int -> Context -> Context setVar name val ctx = - let mp = context . vars $ ctx - in ctx {vars = VarContext $ Map.insert name val mp} + let mp = context . head . vars $ ctx + in let vc = VarContext $ Map.insert name val mp + in ctx {vars = vc : (tail . vars) ctx} diff --git a/src/Statement.hs b/src/Statement.hs index 245a7e4..c33910e 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -33,5 +33,7 @@ data Statement | Skip deriving (Show, Eq) +data Function = Function String [Statement] (Maybe Expression) + reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file From 557b6275357a347b932012b738f0fd6edaa88eec Mon Sep 17 00:00:00 2001 From: veron Date: Mon, 5 Dec 2022 21:59:36 +0100 Subject: [PATCH 34/75] remove duplicated dependency --- stack.yaml | 3 --- 1 file changed, 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 74da509..47eb1c5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,9 +42,6 @@ packages: extra-deps: - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 -extra-deps: - - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 - # Override default flag values for local packages and extra-deps # flags: {} From 00d00c579aa00d939d14f00d03ace8f3aca6e6a5 Mon Sep 17 00:00:00 2001 From: khbminus Date: Tue, 6 Dec 2022 19:06:54 +0100 Subject: [PATCH 35/75] Function without arguments --- src/Context.hs | 50 +++++++++++++++++++++++++++++++++--------------- src/Error.hs | 1 + src/Evaluate.hs | 45 +++++++++++++++++++++++++++++++------------ src/Grammar.hs | 17 +++++++++++++--- src/Statement.hs | 3 ++- 5 files changed, 85 insertions(+), 31 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 2c520b0..2a111cc 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,18 +1,22 @@ {-# LANGUAGE InstanceSigs #-} -module Context (Context (..), InputSource (..), newContext, getVar, setVar) where +module Context (Context (..), InputSource (..), newContext, getVar, setVar, getFun, setFun, loadFunStack, unloadFunStack) where import qualified Data.Map as Map import Error (RuntimeError) +import Statement (Function (..)) -data FunContext = FunContext deriving (Show, Eq) +newtype FunContext = FunContext {funContext :: Map.Map String Function} deriving (Show, Eq) -newtype VarContext = VarContext {context :: Map.Map String Int} deriving (Show, Eq) +newtype VarContext = VarContext {varContext :: Map.Map String Int} deriving (Show, Eq) data InputSource = InputSource {fileName :: String, inputLines :: [String]} deriving (Show) emptyVarContext :: VarContext -emptyVarContext = VarContext {context = Map.empty} +emptyVarContext = VarContext {varContext = Map.empty} + +emptyFunContext :: FunContext +emptyFunContext = FunContext {funContext = Map.empty} data Context = Context { funs :: [FunContext], @@ -28,23 +32,39 @@ instance Eq Context where newContext :: Context newContext = Context - { funs = [FunContext], + { funs = [emptyFunContext], vars = [emptyVarContext], Context.error = Nothing } -getVar :: Context -> String -> Maybe Int -getVar ctx var = helper . vars $ ctx - where - helper :: [VarContext] -> Maybe Int - helper [] = Nothing - helper (x : xs) = case Map.lookup var (context x) of - Nothing -> helper xs - j -> j +getHelper :: String -> [Map.Map String a] -> Maybe a +getHelper _ [] = Nothing +getHelper var (x : xs) = case Map.lookup var x of + Nothing -> getHelper var xs + j -> j + +-- TODO: is some kind of Lens/type-class applicable this? +getVar :: String -> Context -> Maybe Int +getVar var ctx = getHelper var (map varContext (vars ctx)) setVar :: String -> Int -> Context -> Context setVar name val ctx = - let mp = context . head . vars $ ctx + let mp = varContext . head . vars $ ctx in let vc = VarContext $ Map.insert name val mp - in ctx {vars = vc : (tail . vars) ctx} + in ctx {vars = vc : (tail . vars) ctx} + +getFun :: String -> Context -> Maybe Function +getFun var ctx = getHelper var (map funContext (funs ctx)) + +setFun :: String -> Function -> Context -> Context +setFun name f ctx = + let mp = funContext . head . funs $ ctx + in let fc = FunContext $ Map.insert name f mp + in ctx {funs = fc : (tail . funs) ctx} + +loadFunStack :: Function -> Context -> Context +loadFunStack Function {} ctx = ctx {funs = emptyFunContext : funs ctx, vars = emptyVarContext : vars ctx} + +unloadFunStack :: Context -> Context +unloadFunStack ctx = ctx {funs = (tail . funs) ctx, vars = (tail . vars) ctx} diff --git a/src/Error.hs b/src/Error.hs index c4a51d3..c73a809 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -8,4 +8,5 @@ data RuntimeError = ParserError ParsecError | VarNotFound String | FunctionNotFound String | UnexpectedEOF + | CallOfVoidFunctionInExpression String deriving (Show, Eq) \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index ec3336a..67584e2 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,11 +1,11 @@ module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where -import Context (Context (..), InputSource (..), getVar, setVar) +import Context (Context (..), InputSource (..), getFun, getVar, loadFunStack, setVar, unloadFunStack, setFun) import Control.Composition import Control.Monad.State import Error (RuntimeError (..)) import Grammar (number) -import Statement (Expression (..), Operations (..), Statement (..)) +import Statement (Expression (..), Function (..), Operations (..), Statement (..)) import Text.Megaparsec (eof, runParser) import Text.Read (readMaybe) @@ -13,15 +13,33 @@ evaluateExpression :: Expression -> StateT Context IO (Maybe Int) evaluateExpression (Const x) = return $ Just x evaluateExpression (VariableName name) = do ctx <- get - case getVar ctx name of + case getVar name ctx of x@(Just _) -> return x Nothing -> do - put (ctx { Context.error = Just $ VarNotFound name }) + put (ctx {Context.error = Just $ VarNotFound name}) return Nothing evaluateExpression (FunctionCall name _) = do ctx <- get - put $ ctx { Context.error = Just $ FunctionNotFound name } - return Nothing + case getFun name ctx of + Nothing -> + do + put $ ctx {Context.error = Just $ FunctionNotFound name} + return Nothing + Just f -> + do + modify (loadFunStack f) + let Function statements returnExpr = f + evaluateStatements statements + returnValue <- case returnExpr of + Nothing -> + do + put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} + return Nothing + Just expr -> + do + evaluateExpression expr + modify unloadFunStack + return returnValue evaluateExpression (Application op') = do let (x, y, op) = unpack op' x' <- evaluateExpression x @@ -74,14 +92,16 @@ evaluateOneStatement Skip = pure () evaluateOneStatement (While expression statements) = do value <- evaluateExpression expression case value of - Just val | toBool val -> pure () - | otherwise -> evaluateStatements statements + Just val + | toBool val -> pure () + | otherwise -> evaluateStatements statements Nothing -> pure () evaluateOneStatement (If expression trueStatements falseStatements) = do value <- evaluateExpression expression case value of - Just val | toBool val -> evaluateStatements trueStatements - | otherwise -> evaluateStatements falseStatements + Just val + | toBool val -> evaluateStatements trueStatements + | otherwise -> evaluateStatements falseStatements Nothing -> pure () evaluateOneStatement (FunctionCallStatement _ _) = pure () evaluateOneStatement (Write expr) = do @@ -89,13 +109,14 @@ evaluateOneStatement (Write expr) = do case value of Just val -> lift $ print val Nothing -> pure () - evaluateOneStatement (Read var) = do ctx <- get inp <- lift getLine case readMaybe inp :: Maybe Int of - Nothing -> put $ ctx { Context.error = Nothing } + Nothing -> put $ ctx {Context.error = Nothing} Just val -> put $ setVar var val ctx +evaluateOneStatement (FunctionDeclaration name f) = do + modify $ setFun name f evaluateStatements :: [Statement] -> StateT Context IO () evaluateStatements [] = pure () diff --git a/src/Grammar.hs b/src/Grammar.hs index 0ae4b93..be2e692 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -3,10 +3,11 @@ module Grammar where import Control.Monad import Control.Monad.Combinators.Expr import Data.Void -import Statement (Expression (..), Operations (..), Statement (..), reservedKeywords) +import Statement (Expression (..), Function (..), Operations (..), Statement (..), reservedKeywords) import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Debug (dbg) type Parser = Parsec Void String @@ -126,6 +127,15 @@ funCallStatement = arguments :: Parser [Expression] arguments = expression `sepBy` lexeme (symbol ",") +functionDeclaration :: Parser [Statement] +functionDeclaration = + buildDeclaration + <$> (symbol "def" *> name) + <*> (symbol "{" *> statement) + <*> (symbol "}" *> optional (symbol "return" *> expression)) + where + buildDeclaration a b c = [FunctionDeclaration a (Function b c)] + skip :: Parser [Statement] skip = [Skip] <$ symbol "skip" @@ -134,8 +144,9 @@ split = concat <$> (statement `sepBy1` symbol ";") statement :: Parser [Statement] statement = - try while <|> try ifThenElse - <|> (concat <$> (terms `sepBy1` symbol ";")) + try while + <|> try ifThenElse + <|> concat <$> (terms `sepBy1` symbol ";") where terms = choice diff --git a/src/Statement.hs b/src/Statement.hs index c33910e..b986f3b 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -26,6 +26,7 @@ data Expression data Statement = Let String Expression | FunctionCallStatement String [Expression] + | FunctionDeclaration String Function | Write Expression | Read String | While Expression [Statement] @@ -33,7 +34,7 @@ data Statement | Skip deriving (Show, Eq) -data Function = Function String [Statement] (Maybe Expression) +data Function = Function [Statement] (Maybe Expression) deriving (Show, Eq) reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file From 3bcee049db4e224f8d9f753aa83485609a3ddcb9 Mon Sep 17 00:00:00 2001 From: khbminus Date: Tue, 6 Dec 2022 19:54:27 +0100 Subject: [PATCH 36/75] Argument support --- src/Context.hs | 8 ++++++-- src/Error.hs | 1 + src/Evaluate.hs | 46 ++++++++++++++++++++++++++++++++-------------- src/Grammar.hs | 3 ++- src/Statement.hs | 2 +- 5 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 2a111cc..6dddfdb 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -63,8 +63,12 @@ setFun name f ctx = in let fc = FunContext $ Map.insert name f mp in ctx {funs = fc : (tail . funs) ctx} -loadFunStack :: Function -> Context -> Context -loadFunStack Function {} ctx = ctx {funs = emptyFunContext : funs ctx, vars = emptyVarContext : vars ctx} +loadFunStack :: Function -> [Int] -> Context -> Context +loadFunStack (Function args _ _) values ctx = ctx {funs = emptyFunContext : funs ctx, vars = insertAll (zip args values) emptyVarContext : vars ctx} + where + insertAll :: [(String, Int)] -> VarContext -> VarContext + insertAll [] x = x + insertAll ((name, value) : xs) (VarContext mp) = insertAll xs VarContext {varContext = Map.insert name value mp} unloadFunStack :: Context -> Context unloadFunStack ctx = ctx {funs = (tail . funs) ctx, vars = (tail . vars) ctx} diff --git a/src/Error.hs b/src/Error.hs index c73a809..42dbff8 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -9,4 +9,5 @@ data RuntimeError = ParserError ParsecError | FunctionNotFound String | UnexpectedEOF | CallOfVoidFunctionInExpression String + | InvalidNumberOfArguments String Int Int deriving (Show, Eq) \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 67584e2..8ed3731 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -18,7 +18,7 @@ evaluateExpression (VariableName name) = do Nothing -> do put (ctx {Context.error = Just $ VarNotFound name}) return Nothing -evaluateExpression (FunctionCall name _) = do +evaluateExpression (FunctionCall name argumentValues) = do ctx <- get case getFun name ctx of Nothing -> @@ -27,19 +27,37 @@ evaluateExpression (FunctionCall name _) = do return Nothing Just f -> do - modify (loadFunStack f) - let Function statements returnExpr = f - evaluateStatements statements - returnValue <- case returnExpr of - Nothing -> - do - put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} - return Nothing - Just expr -> - do - evaluateExpression expr - modify unloadFunStack - return returnValue + argumentValues' <- evaluateList argumentValues + case argumentValues' of + Nothing -> return Nothing + Just args -> do + modify (loadFunStack f args) -- FIXME: check length + let Function _ statements returnExpr = f + evaluateStatements statements + returnValue <- case returnExpr of + Nothing -> + do + put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} + return Nothing + Just expr -> + do + evaluateExpression expr + modify unloadFunStack + return returnValue + where + evaluateList :: [Expression] -> StateT Context IO (Maybe [Int]) + evaluateList [] = return $ Just [] + evaluateList (x : xs) = do + x' <- evaluateExpression x + case x' of + Just y -> do + xs' <- evaluateList xs + case xs' of + Just ys -> return $ Just (y : ys) + Nothing -> return Nothing + Nothing -> return Nothing + + evaluateExpression (Application op') = do let (x, y, op) = unpack op' x' <- evaluateExpression x diff --git a/src/Grammar.hs b/src/Grammar.hs index be2e692..03a068d 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -131,10 +131,11 @@ functionDeclaration :: Parser [Statement] functionDeclaration = buildDeclaration <$> (symbol "def" *> name) + <*> parens (name `sepBy` symbol ",") <*> (symbol "{" *> statement) <*> (symbol "}" *> optional (symbol "return" *> expression)) where - buildDeclaration a b c = [FunctionDeclaration a (Function b c)] + buildDeclaration a b c d = [FunctionDeclaration a (Function b c d)] skip :: Parser [Statement] skip = [Skip] <$ symbol "skip" diff --git a/src/Statement.hs b/src/Statement.hs index b986f3b..b536b29 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -34,7 +34,7 @@ data Statement | Skip deriving (Show, Eq) -data Function = Function [Statement] (Maybe Expression) deriving (Show, Eq) +data Function = Function [String] [Statement] (Maybe Expression) deriving (Show, Eq) reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file From 66fa5cb760ad9f868a8265717db4c3e4b3a66229 Mon Sep 17 00:00:00 2001 From: khbminus Date: Tue, 6 Dec 2022 19:56:31 +0100 Subject: [PATCH 37/75] Statement support --- src/Evaluate.hs | 57 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 41 insertions(+), 16 deletions(-) diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 8ed3731..bfc680a 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE BangPatterns #-} + module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where -import Context (Context (..), InputSource (..), getFun, getVar, loadFunStack, setVar, unloadFunStack, setFun) +import Context (Context (..), InputSource (..), getFun, getVar, loadFunStack, setFun, setVar, unloadFunStack) import Control.Composition import Control.Monad.State import Error (RuntimeError (..)) @@ -9,6 +11,18 @@ import Statement (Expression (..), Function (..), Operations (..), Statement (.. import Text.Megaparsec (eof, runParser) import Text.Read (readMaybe) +evaluateList :: [Expression] -> StateT Context IO (Maybe [Int]) +evaluateList [] = return $ Just [] +evaluateList (x : xs) = do + x' <- evaluateExpression x + case x' of + Just y -> do + xs' <- evaluateList xs + case xs' of + Just ys -> return $ Just (y : ys) + Nothing -> return Nothing + Nothing -> return Nothing + evaluateExpression :: Expression -> StateT Context IO (Maybe Int) evaluateExpression (Const x) = return $ Just x evaluateExpression (VariableName name) = do @@ -44,20 +58,6 @@ evaluateExpression (FunctionCall name argumentValues) = do evaluateExpression expr modify unloadFunStack return returnValue - where - evaluateList :: [Expression] -> StateT Context IO (Maybe [Int]) - evaluateList [] = return $ Just [] - evaluateList (x : xs) = do - x' <- evaluateExpression x - case x' of - Just y -> do - xs' <- evaluateList xs - case xs' of - Just ys -> return $ Just (y : ys) - Nothing -> return Nothing - Nothing -> return Nothing - - evaluateExpression (Application op') = do let (x, y, op) = unpack op' x' <- evaluateExpression x @@ -121,7 +121,32 @@ evaluateOneStatement (If expression trueStatements falseStatements) = do | toBool val -> evaluateStatements trueStatements | otherwise -> evaluateStatements falseStatements Nothing -> pure () -evaluateOneStatement (FunctionCallStatement _ _) = pure () +evaluateOneStatement (FunctionCallStatement name argumentValues) = do + ctx <- get + case getFun name ctx of + Nothing -> + do + put $ ctx {Context.error = Just $ FunctionNotFound name} + return () + Just f -> + do + argumentValues' <- evaluateList argumentValues + case argumentValues' of + Nothing -> return () + Just args -> do + modify (loadFunStack f args) -- FIXME: check length + let Function _ statements returnExpr = f + evaluateStatements statements + !returnValue <- case returnExpr of + Nothing -> + do + put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} + return Nothing + Just expr -> + do + evaluateExpression expr + modify unloadFunStack + return () evaluateOneStatement (Write expr) = do value <- evaluateExpression expr case value of From 0404ee4b4146025a4f84ef2c56a0d2ef4153524d Mon Sep 17 00:00:00 2001 From: veron Date: Tue, 6 Dec 2022 22:55:38 +0100 Subject: [PATCH 38/75] Maybe -> MaybeT --- src/Context.hs | 31 ++++++++++-- src/Evaluate.hs | 112 ++++++++++++------------------------------ test/Test/Evaluate.hs | 23 +++++++++ 3 files changed, 82 insertions(+), 84 deletions(-) create mode 100644 test/Test/Evaluate.hs diff --git a/src/Context.hs b/src/Context.hs index 6dddfdb..7fbdf14 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,10 +1,12 @@ {-# LANGUAGE InstanceSigs #-} -module Context (Context (..), InputSource (..), newContext, getVar, setVar, getFun, setFun, loadFunStack, unloadFunStack) where +module Context where import qualified Data.Map as Map -import Error (RuntimeError) +import Error (RuntimeError (FunctionNotFound, VarNotFound)) import Statement (Function (..)) +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.State newtype FunContext = FunContext {funContext :: Map.Map String Function} deriving (Show, Eq) @@ -48,6 +50,13 @@ getHelper var (x : xs) = case Map.lookup var x of getVar :: String -> Context -> Maybe Int getVar var ctx = getHelper var (map varContext (vars ctx)) +getVarT :: String -> MaybeT (StateT Context IO) Int +getVarT var = do + cxt <- get + case getVar var cxt of + Nothing -> do { lift $ setErrorT $ VarNotFound var; mzero } + Just v -> return v + setVar :: String -> Int -> Context -> Context setVar name val ctx = let mp = varContext . head . vars $ ctx @@ -55,7 +64,23 @@ setVar name val ctx = in ctx {vars = vc : (tail . vars) ctx} getFun :: String -> Context -> Maybe Function -getFun var ctx = getHelper var (map funContext (funs ctx)) +getFun fun ctx = getHelper fun (map funContext (funs ctx)) + +getFunT :: String -> MaybeT (StateT Context IO) Function +getFunT fun = do + ctx <- get + case getFun fun ctx of + Nothing -> do { lift $ setErrorT $ FunctionNotFound fun; mzero } + Just f -> return f + + +setError :: RuntimeError -> Context -> Context +setError err cxt = cxt { Context.error = Just err } + +setErrorT :: RuntimeError -> StateT Context IO () +setErrorT err = do + cxt <- get + put $ setError err cxt setFun :: String -> Function -> Context -> Context setFun name f ctx = diff --git a/src/Evaluate.hs b/src/Evaluate.hs index bfc680a..32dd141 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,70 +1,44 @@ {-# LANGUAGE BangPatterns #-} -module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression) where +module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression, evaluateList) where -import Context (Context (..), InputSource (..), getFun, getVar, loadFunStack, setFun, setVar, unloadFunStack) +import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack) import Control.Composition import Control.Monad.State -import Error (RuntimeError (..)) -import Grammar (number) import Statement (Expression (..), Function (..), Operations (..), Statement (..)) -import Text.Megaparsec (eof, runParser) import Text.Read (readMaybe) +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Data.Maybe (isNothing, fromJust) -evaluateList :: [Expression] -> StateT Context IO (Maybe [Int]) -evaluateList [] = return $ Just [] +evaluateList :: [Expression] -> MaybeT (StateT Context IO) [Int] +evaluateList [] = return [] evaluateList (x : xs) = do x' <- evaluateExpression x - case x' of - Just y -> do - xs' <- evaluateList xs - case xs' of - Just ys -> return $ Just (y : ys) - Nothing -> return Nothing - Nothing -> return Nothing + xs' <- evaluateList xs + return $ x' : xs' + + +evaluateExpression :: Expression -> MaybeT (StateT Context IO) Int +evaluateExpression (Const x) = return x +evaluateExpression (VariableName name) = getVarT name -evaluateExpression :: Expression -> StateT Context IO (Maybe Int) -evaluateExpression (Const x) = return $ Just x -evaluateExpression (VariableName name) = do - ctx <- get - case getVar name ctx of - x@(Just _) -> return x - Nothing -> do - put (ctx {Context.error = Just $ VarNotFound name}) - return Nothing evaluateExpression (FunctionCall name argumentValues) = do - ctx <- get - case getFun name ctx of - Nothing -> - do - put $ ctx {Context.error = Just $ FunctionNotFound name} - return Nothing - Just f -> - do - argumentValues' <- evaluateList argumentValues - case argumentValues' of - Nothing -> return Nothing - Just args -> do - modify (loadFunStack f args) -- FIXME: check length - let Function _ statements returnExpr = f - evaluateStatements statements - returnValue <- case returnExpr of - Nothing -> - do - put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} - return Nothing - Just expr -> - do - evaluateExpression expr - modify unloadFunStack - return returnValue + f <- getFunT name + args <- evaluateList argumentValues + modify (loadFunStack f args) -- FIXME: check length + let Function _ statements returnExpr = f + lift $ evaluateStatements statements + when (isNothing returnExpr) $ do { modify unloadFunStack; mzero } + let expr = fromJust returnExpr + returnValue <- evaluateExpression expr + modify unloadFunStack + return returnValue + evaluateExpression (Application op') = do let (x, y, op) = unpack op' x' <- evaluateExpression x y' <- evaluateExpression y - case (x', y') of - (Just val_x, Just val_y) -> return $ Just $ op val_x val_y - (_, _) -> return Nothing + return $ op x' y' where -- FIXME: fix that crappy design unpack :: Operations -> (Expression, Expression, Int -> Int -> Int) @@ -102,53 +76,29 @@ toBool _ = True evaluateOneStatement :: Statement -> StateT Context IO () evaluateOneStatement (Let name value) = do - value' <- evaluateExpression value + value' <- runMaybeT $ evaluateExpression value case value' of Just val -> modify (setVar name val) Nothing -> pure () evaluateOneStatement Skip = pure () evaluateOneStatement (While expression statements) = do - value <- evaluateExpression expression + value <- runMaybeT $ evaluateExpression expression case value of Just val | toBool val -> pure () | otherwise -> evaluateStatements statements Nothing -> pure () evaluateOneStatement (If expression trueStatements falseStatements) = do - value <- evaluateExpression expression + value <- runMaybeT $ evaluateExpression expression case value of Just val | toBool val -> evaluateStatements trueStatements | otherwise -> evaluateStatements falseStatements Nothing -> pure () -evaluateOneStatement (FunctionCallStatement name argumentValues) = do - ctx <- get - case getFun name ctx of - Nothing -> - do - put $ ctx {Context.error = Just $ FunctionNotFound name} - return () - Just f -> - do - argumentValues' <- evaluateList argumentValues - case argumentValues' of - Nothing -> return () - Just args -> do - modify (loadFunStack f args) -- FIXME: check length - let Function _ statements returnExpr = f - evaluateStatements statements - !returnValue <- case returnExpr of - Nothing -> - do - put $ ctx {Context.error = Just $ CallOfVoidFunctionInExpression name} - return Nothing - Just expr -> - do - evaluateExpression expr - modify unloadFunStack - return () +evaluateOneStatement (FunctionCallStatement name argumentValues) = + void (runMaybeT (evaluateExpression $ FunctionCall name argumentValues)) evaluateOneStatement (Write expr) = do - value <- evaluateExpression expr + value <- runMaybeT $ evaluateExpression expr case value of Just val -> lift $ print val Nothing -> pure () diff --git a/test/Test/Evaluate.hs b/test/Test/Evaluate.hs new file mode 100644 index 0000000..db8d115 --- /dev/null +++ b/test/Test/Evaluate.hs @@ -0,0 +1,23 @@ +module Test.Evaluate where + +import Evaluate (evaluateList) +import Context (newContext) +import Test.HUnit +import Text.Megaparsec +import Statement (Expression(..)) +import Control.Monad.State (evalStateT) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT, runMaybeT)) + +testEvaluateList :: [Expression] -> Maybe [Int] -> IO Bool +testEvaluateList expr res = do + eval <- evalStateT (runMaybeT $ evaluateList expr) newContext + pure $ eval == res + +unit_evaluateExprList = do + let assert msg action = action >>= assertBool msg + + assert "success" $ testEvaluateList [Const 1] (Just [1]) + assert "success" $ testEvaluateList [Const 1, Const 2] (Just [1, 2]) + assert "failure" $ testEvaluateList [VariableName "var"] Nothing + assert "failure" $ testEvaluateList [Const 1, VariableName "var"] Nothing + assert "failure" $ testEvaluateList [VariableName "var", Const 2] Nothing From 73443b0afcd75b60300f73fccc4b34801abba761 Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 8 Dec 2022 15:25:41 +0100 Subject: [PATCH 39/75] ExpressionOrStatement parser --- L-static-analyzer.cabal | 3 ++- src/Grammar.hs | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 1278022..56daf6b 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -72,8 +72,9 @@ test-suite L-static-analyzer-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: - Test.Execute Test.ConsoleParser + Test.Execute + Test.Parsers Paths_L_static_analyzer hs-source-dirs: test diff --git a/src/Grammar.hs b/src/Grammar.hs index 0ae4b93..98e859c 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -145,3 +145,6 @@ statement = try funCallStatement, letVariable ] + +statementOrExpression :: Parser (Either [Statement] Expression) +statementOrExpression = fmap Left (try statement) <|> fmap Right expression \ No newline at end of file From 276c18fa5938db77ef2f6560fd02cff350fba819 Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 8 Dec 2022 16:59:18 +0100 Subject: [PATCH 40/75] print expression result in REPL --- app/Main.hs | 4 ++-- src/Console.hs | 24 +++++++++++++++++++++--- src/ConsoleParser.hs | 14 +++++++++++++- src/Context.hs | 2 +- src/Execute.hs | 10 ++++++---- src/Grammar.hs | 3 --- 6 files changed, 43 insertions(+), 14 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9b590c8..5755680 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -22,10 +22,10 @@ main = do runAction :: Action -> IO () runAction (Action (FileInput path) varContext) = do i <- readFile path - let context = newContext { Context.vars = getVarContext varContext} + let context = newContext { Context.vars = [getVarContext varContext]} evalStateT (runLoop $ lines i) context -- выход: q runAction (Action Interactive varContext) = - let context = newContext { Context.vars = getVarContext varContext} in + let context = newContext { Context.vars = [getVarContext varContext]} in evalStateT readEvalWriteLoop context diff --git a/src/Console.hs b/src/Console.hs index 749f100..48319a4 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -1,11 +1,29 @@ module Console where -import Context (Context(..)) -import Execute (execute, run) +import Context (Context(..), setErrorT) +import Execute (run, execute) import System.IO ( hFlush, stdout ) -import Control.Monad (when) +import Control.Monad ( when, guard ) import Control.Monad.State ( MonadTrans(lift) ) import Control.Monad.Trans.State ( StateT, get, put ) +import Evaluate (evaluateStatements, evaluateExpression) +import ConsoleParser (REPLInput(..), parseStatementOrExpression) +import Error (RuntimeError(ParserError)) +import Control.Monad.Trans.Maybe (runMaybeT) +import Data.Maybe (isJust, fromJust, isNothing) + + +executeREPL :: String -> StateT Context IO () +executeREPL str = do + context <- get + guard (isNothing (Context.error context)) + case parseStatementOrExpression str of + Left err -> setErrorT $ ParserError err + Right (CStatement st) -> evaluateStatements st + Right (CExpression ex) -> do + res <- runMaybeT $ evaluateExpression ex + guard (isJust res) + lift $ print (fromJust res) -- TODO: print expression results readEvalWriteLoop :: StateT Context IO () diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index 57d2746..3b25f37 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -3,8 +3,10 @@ module ConsoleParser where import qualified Options.Applicative as Optparse import qualified Text.Megaparsec as Megaparsec import qualified Grammar as LParser -import Text.Megaparsec ( (), (<|>) ) +import Text.Megaparsec ( (), (<|>), MonadParsec(try, eof) ) import Context (VarContext, setVarContext, emptyVarContext) +import Statement (Expression, Statement) +import Error (ParsecError) -- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом data Action = Action @@ -16,6 +18,15 @@ data Action = Action actionParser :: Optparse.Parser Action actionParser = Action <$> (inputParser <|> pure Interactive) <*> varsParser +data REPLInput = CStatement [Statement] + | CExpression Expression + +statementOrExpression :: LParser.Parser REPLInput +statementOrExpression = fmap CStatement (try LParser.statement) <|> fmap CExpression LParser.expression + +parseStatementOrExpression :: String -> Either ParsecError REPLInput +parseStatementOrExpression = Megaparsec.parse (statementOrExpression <* eof) "" + -- Тип входных данных data Input = FileInput FilePath -- Имя входного файла | Interactive @@ -45,3 +56,4 @@ getVarContext (x:xs) = Left err -> Prelude.error $ show err Right (var, val) -> setVarContext var val (getVarContext xs) getVarContext [] = emptyVarContext + diff --git a/src/Context.hs b/src/Context.hs index 1588f97..bb8615f 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -23,7 +23,7 @@ emptyFunContext = FunContext {funContext = Map.empty} setVarContext :: String -> Int -> VarContext -> VarContext setVarContext name val ctx = - let mp = context ctx in + let mp = varContext ctx in VarContext $ Map.insert name val mp data Context = Context diff --git a/src/Execute.hs b/src/Execute.hs index 06f2351..46a5673 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -10,9 +10,11 @@ import Data.Maybe (isNothing) import Text.Megaparsec.Error (ParseErrorBundle) import Data.Void import Statement (Statement) +import ConsoleParser (REPLInput, statementOrExpression) +import Context (setErrorT) -parseInput :: String -> Either (ParseErrorBundle String Void) [Statement] -parseInput = parse (statement <* eof) "" +parseStatement :: String -> Either (ParseErrorBundle String Void) [Statement] +parseStatement = parse (statement <* eof) "" run :: [String] -> StateT Context IO () run = foldr ((>>) . execute) (return ()) @@ -21,6 +23,6 @@ execute :: String -> StateT Context IO () execute str = do context <- get guard ( isNothing (Context.error context) ) - case parseInput str of - Left err -> put $ context { Context.error = Just $ ParserError err } + case parseStatement str of + Left err -> setErrorT $ ParserError err Right statements -> evaluateStatements statements diff --git a/src/Grammar.hs b/src/Grammar.hs index ef4e20c..03a068d 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -157,6 +157,3 @@ statement = try funCallStatement, letVariable ] - -statementOrExpression :: Parser (Either [Statement] Expression) -statementOrExpression = fmap Left (try statement) <|> fmap Right expression \ No newline at end of file From c9927d2255aa2478f934afeb69b9588aae17a93b Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 8 Dec 2022 17:15:54 +0100 Subject: [PATCH 41/75] Test fixes --- L-static-analyzer.cabal | 1 + test/Test/ConsoleParser.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 56daf6b..47ad7f5 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -73,6 +73,7 @@ test-suite L-static-analyzer-test main-is: Test.hs other-modules: Test.ConsoleParser + Test.Evaluate Test.Execute Test.Parsers Paths_L_static_analyzer diff --git a/test/Test/ConsoleParser.hs b/test/Test/ConsoleParser.hs index 0c8d79c..cae2bae 100644 --- a/test/Test/ConsoleParser.hs +++ b/test/Test/ConsoleParser.hs @@ -30,7 +30,7 @@ unit_varArgParser = do assertBool "6" $ failure "x=vr" varContextComp :: [String] -> [(String, Int)] -> Bool -varContextComp inp cxt = getVarContext inp == VarContext { context = Map.fromList cxt } +varContextComp inp cxt = getVarContext inp == VarContext { varContext = Map.fromList cxt } unit_getVarContext :: IO () unit_getVarContext = do From d2923f57a7e39fe669e2098edbf9a65c307a8da6 Mon Sep 17 00:00:00 2001 From: veron Date: Sun, 11 Dec 2022 11:59:37 +0100 Subject: [PATCH 42/75] refactor and fix REPL --- src/Console.hs | 27 ++++----------------------- src/ConsoleParser.hs | 13 +------------ src/Context.hs | 9 ++++++--- src/Execute.hs | 33 +++++++++++++++++++-------------- src/Grammar.hs | 15 ++++++++++++++- test/Test/Parsers.hs | 14 ++++++++++++++ 6 files changed, 58 insertions(+), 53 deletions(-) diff --git a/src/Console.hs b/src/Console.hs index 48319a4..c0db6b0 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -1,35 +1,16 @@ module Console where -import Context (Context(..), setErrorT) -import Execute (run, execute) +import Context (Context(..)) +import Execute (run, executeREPL) import System.IO ( hFlush, stdout ) -import Control.Monad ( when, guard ) +import Control.Monad ( when ) import Control.Monad.State ( MonadTrans(lift) ) import Control.Monad.Trans.State ( StateT, get, put ) -import Evaluate (evaluateStatements, evaluateExpression) -import ConsoleParser (REPLInput(..), parseStatementOrExpression) -import Error (RuntimeError(ParserError)) -import Control.Monad.Trans.Maybe (runMaybeT) -import Data.Maybe (isJust, fromJust, isNothing) - -executeREPL :: String -> StateT Context IO () -executeREPL str = do - context <- get - guard (isNothing (Context.error context)) - case parseStatementOrExpression str of - Left err -> setErrorT $ ParserError err - Right (CStatement st) -> evaluateStatements st - Right (CExpression ex) -> do - res <- runMaybeT $ evaluateExpression ex - guard (isJust res) - lift $ print (fromJust res) - --- TODO: print expression results readEvalWriteLoop :: StateT Context IO () readEvalWriteLoop = do input <- lift $ prompt "L: " - when (input /= "q") $ execute input >> unsetError >> readEvalWriteLoop + when (input /= "q") $ executeREPL input >> unsetError >> readEvalWriteLoop runLoop :: [String] -> StateT Context IO () runLoop input = do diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index 3b25f37..be27d41 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -3,10 +3,8 @@ module ConsoleParser where import qualified Options.Applicative as Optparse import qualified Text.Megaparsec as Megaparsec import qualified Grammar as LParser -import Text.Megaparsec ( (), (<|>), MonadParsec(try, eof) ) +import Text.Megaparsec ( (), (<|>) ) import Context (VarContext, setVarContext, emptyVarContext) -import Statement (Expression, Statement) -import Error (ParsecError) -- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом data Action = Action @@ -18,15 +16,6 @@ data Action = Action actionParser :: Optparse.Parser Action actionParser = Action <$> (inputParser <|> pure Interactive) <*> varsParser -data REPLInput = CStatement [Statement] - | CExpression Expression - -statementOrExpression :: LParser.Parser REPLInput -statementOrExpression = fmap CStatement (try LParser.statement) <|> fmap CExpression LParser.expression - -parseStatementOrExpression :: String -> Either ParsecError REPLInput -parseStatementOrExpression = Megaparsec.parse (statementOrExpression <* eof) "" - -- Тип входных данных data Input = FileInput FilePath -- Имя входного файла | Interactive diff --git a/src/Context.hs b/src/Context.hs index bb8615f..539af56 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -63,7 +63,9 @@ getVarT :: String -> MaybeT (StateT Context IO) Int getVarT var = do cxt <- get case getVar var cxt of - Nothing -> do { lift $ setErrorT $ VarNotFound var; mzero } + Nothing -> do + lift $ setErrorT $ VarNotFound var + mzero Just v -> return v setVar :: String -> Int -> Context -> Context @@ -79,10 +81,11 @@ getFunT :: String -> MaybeT (StateT Context IO) Function getFunT fun = do ctx <- get case getFun fun ctx of - Nothing -> do { lift $ setErrorT $ FunctionNotFound fun; mzero } + Nothing -> do + lift $ setErrorT $ FunctionNotFound fun + mzero Just f -> return f - setError :: RuntimeError -> Context -> Context setError err cxt = cxt { Context.error = Just err } diff --git a/src/Execute.hs b/src/Execute.hs index 46a5673..e80f833 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,20 +1,12 @@ -module Execute (run, execute) where +module Execute (run, execute, executeREPL) where -import Context (Context (..)) +import Context ( Context(..), setErrorT ) import Control.Monad.State import Error (RuntimeError (..)) -import Evaluate (evaluateStatements) -import Grammar (statement) -import Text.Megaparsec (eof, parse) -import Data.Maybe (isNothing) -import Text.Megaparsec.Error (ParseErrorBundle) -import Data.Void -import Statement (Statement) -import ConsoleParser (REPLInput, statementOrExpression) -import Context (setErrorT) - -parseStatement :: String -> Either (ParseErrorBundle String Void) [Statement] -parseStatement = parse (statement <* eof) "" +import Evaluate (evaluateStatements, evaluateExpression) +import Grammar (parseStatement, REPLInput (..), parseStatementOrExpression) +import Data.Maybe (isNothing, isJust, fromJust) +import Control.Monad.Trans.Maybe (MaybeT(..)) run :: [String] -> StateT Context IO () run = foldr ((>>) . execute) (return ()) @@ -26,3 +18,16 @@ execute str = do case parseStatement str of Left err -> setErrorT $ ParserError err Right statements -> evaluateStatements statements + +executeREPL :: String -> StateT Context IO () +executeREPL str = do + context <- get + guard ( isNothing (Context.error context) ) + case parseStatementOrExpression str of + Left err -> setErrorT $ ParserError err + Right (ConsoleStatement st) -> evaluateStatements st + Right (ConsoleExpression ex) -> do + res <- runMaybeT $ evaluateExpression ex + case res of + Nothing -> return () + Just val -> lift $ print val diff --git a/src/Grammar.hs b/src/Grammar.hs index 03a068d..6ad9559 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -7,7 +7,7 @@ import Statement (Expression (..), Function (..), Operations (..), Statement (.. import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Text.Megaparsec.Debug (dbg) +import Error (ParsecError) type Parser = Parsec Void String @@ -157,3 +157,16 @@ statement = try funCallStatement, letVariable ] + +parseStatement :: String -> Either (ParseErrorBundle String Void) [Statement] +parseStatement = parse (statement <* eof) "" + +data REPLInput = ConsoleStatement [Statement] + | ConsoleExpression Expression + deriving (Eq, Show) + +statementOrExpression :: Parser REPLInput +statementOrExpression = fmap ConsoleStatement (try statement) <|> fmap ConsoleExpression expression + +parseStatementOrExpression :: String -> Either ParsecError REPLInput +parseStatementOrExpression = parse (statementOrExpression <* eof) "" diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 4fd67bf..3dc7f74 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -4,6 +4,7 @@ import Grammar import Statement import Test.HUnit import Text.Megaparsec +import Grammar (REPLInput(..)) parseSuccessful :: Eq a => Parser a -> String -> a -> Bool parseSuccessful parser line result = case parse (parser <* eof) "" line of @@ -186,3 +187,16 @@ unit_statement = do Let "y" $ VariableName "b" ] ] + +unit_expressionOrStatement = do + assertBool "failure" $ fail "rtwe tre" + assertBool "variable" $ success "var" (ConsoleExpression $ VariableName "var") + + where + success inp expected = case parseStatementOrExpression inp of + Left _ -> False + Right res -> res == expected + fail inp = case parseStatementOrExpression inp of + Left _ -> True + Right _ -> False + From 1a5339d03ce1ea45052e3b16e8503fc946a2429d Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 22 Dec 2022 09:49:11 +0100 Subject: [PATCH 43/75] revert Context.hs --- src/Context.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index 539af56..e694462 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -63,9 +63,7 @@ getVarT :: String -> MaybeT (StateT Context IO) Int getVarT var = do cxt <- get case getVar var cxt of - Nothing -> do - lift $ setErrorT $ VarNotFound var - mzero + Nothing -> do { lift $ setErrorT $ VarNotFound var; mzero } Just v -> return v setVar :: String -> Int -> Context -> Context @@ -81,9 +79,7 @@ getFunT :: String -> MaybeT (StateT Context IO) Function getFunT fun = do ctx <- get case getFun fun ctx of - Nothing -> do - lift $ setErrorT $ FunctionNotFound fun - mzero + Nothing -> do { lift $ setErrorT $ FunctionNotFound fun; mzero } Just f -> return f setError :: RuntimeError -> Context -> Context From 0a01db29bf43f658d74ea0d49dc140b56090addf Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 22 Dec 2022 18:39:25 +0100 Subject: [PATCH 44/75] tests fixed --- src/Context.hs | 33 ++++++++++-- src/Evaluate.hs | 33 +++++++++--- test/Test/Execute.hs | 126 ++++++++++++++++++------------------------- 3 files changed, 105 insertions(+), 87 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index bb8615f..ae59a4a 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -15,6 +15,15 @@ newtype VarContext = VarContext {varContext :: Map.Map String Int} deriving (Sho data InputSource = InputSource {fileName :: String, inputLines :: [String]} deriving (Show) +newtype Buffer = Buffer [String] deriving (Show, Eq) + +push :: String -> Buffer -> Buffer +push str (Buffer buf) = Buffer $ buf ++ [str] + +pop :: Buffer -> (Buffer, Maybe String) +pop (Buffer (x:xs)) = (Buffer xs, Just x) +pop (Buffer []) = (Buffer [], Nothing) + emptyVarContext :: VarContext emptyVarContext = VarContext {varContext = Map.empty} @@ -29,7 +38,9 @@ setVarContext name val ctx = data Context = Context { funs :: [FunContext], vars :: [VarContext], - error :: Maybe RuntimeError + error :: Maybe RuntimeError, + input :: Buffer, + output :: Buffer } deriving (Show) @@ -45,7 +56,9 @@ newContext = Context { funs = [emptyFunContext], vars = [emptyVarContext], - Context.error = Nothing + Context.error = Nothing, + input = Buffer [], + output = Buffer [] } getHelper :: String -> [Map.Map String a] -> Maybe a @@ -87,9 +100,21 @@ setError :: RuntimeError -> Context -> Context setError err cxt = cxt { Context.error = Just err } setErrorT :: RuntimeError -> StateT Context IO () -setErrorT err = do +setErrorT err = get >>= put . setError err + +pushOutput :: String -> StateT Context IO () +pushOutput str = do cxt <- get - put $ setError err cxt + put $ cxt { output = push str (output cxt) } + +popInput :: MaybeT (StateT Context IO) String +popInput = do + cxt <- get + let (buf, h) = pop $ input cxt + ret <- maybe mzero return h + put $ cxt { input = buf } + return ret + setFun :: String -> Function -> Context -> Context setFun name f ctx = diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 0ec4892..90d7af2 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -2,13 +2,16 @@ module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression, evaluateList) where -import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack) +import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack, popInput, setErrorT, pushOutput) import Control.Composition import Control.Monad.State import Statement (Expression (..), Function (..), Operations (..), Statement (..)) import Text.Read (readMaybe) import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) -import Data.Maybe (isNothing, fromJust) +import Data.Maybe (isNothing, fromJust, isJust) +import Error (RuntimeError(InvalidInput, UnexpectedEOF)) +import GHC.IO.Handle (hIsOpen) +import GHC.IO.Handle.FD (stdin) evaluateList :: [Expression] -> MaybeT (StateT Context IO) [Int] evaluateList [] = return [] @@ -100,19 +103,33 @@ evaluateOneStatement (If expression trueStatements falseStatements) = do | toBool val -> evaluateStatements trueStatements | otherwise -> evaluateStatements falseStatements Nothing -> pure () + evaluateOneStatement (FunctionCallStatement name argumentValues) = void (runMaybeT (evaluateExpression $ FunctionCall name argumentValues)) + evaluateOneStatement (Write expr) = do value <- runMaybeT $ evaluateExpression expr case value of - Just val -> lift $ print val + Just val -> pushOutput $ show val Nothing -> pure () + evaluateOneStatement (Read var) = do - ctx <- get - inp <- lift getLine - case readMaybe inp :: Maybe Int of - Nothing -> put $ ctx {Context.error = Nothing} - Just val -> put $ setVar var val ctx + cxt <- get + inp <- runMaybeT popInput + str <- if isJust inp then pure inp else runMaybeT maybeGetLine + if isNothing str then return () + else let justStr = fromJust str in case readMaybe justStr :: Maybe Int of + Nothing -> setErrorT $ InvalidInput justStr + Just val -> put $ setVar var val cxt + + where + maybeGetLine :: MaybeT (StateT Context IO) String + maybeGetLine = do + cond <- liftIO $ hIsOpen stdin + if cond + then liftIO getLine + else do { lift $ setErrorT UnexpectedEOF; mzero } + evaluateOneStatement (FunctionDeclaration name f) = do modify $ setFun name f diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index 6e413d8..7dda55a 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -1,77 +1,53 @@ {-# LANGUAGE LambdaCase #-} module Test.Execute where --- ---import Test.Tasty.HUnit (assertEqual) ---import Statement (Expression(VariableName, Const), Statement (Skip, Write, Read)) ---import Execute (execute) ---import Context (Context(..), empty, setVar, setError) ---import Error (RuntimeError(VarNameError, UnsupportedError, InvalidInputError)) ---import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, modifyIORef) ---import qualified GHC.Err as Err --- ---initTestContext :: [String] -> IO (Context, IO [String]) ---initTestContext input = do --- inputsRef <- newIORef input --- outputsRef <- newIORef [] --- let getOutput :: IO [String] --- getOutput = readIORef outputsRef --- --- let getTestLine :: IO String --- getTestLine = atomicModifyIORef inputsRef (\case --- i : is -> (is,i) -- the i becomes the return value --- [] -> Err.error "fake inputs exhausted") --- let putTestLine :: String -> IO () --- putTestLine str = atomicModifyIORef outputsRef (\inputs -> (inputs ++ [str], ())) --- --- pure (empty {getNextLine = getTestLine, putLine = putTestLine }, getOutput) --- ---unit_executeWrite :: IO () ---unit_executeWrite = do --- let writeConst = Write (Const 1) --- let writeVar = Write (VariableName "var") --- --- (testContext, getOutput) <- initTestContext [] --- exitContext <- execute testContext [writeConst] --- output <- getOutput --- assertEqual "write const" testContext exitContext --- assertEqual "write const" ["1"] output --- --- (testContext, getOutput) <- initTestContext [] --- exitContext <- execute testContext [writeVar] --- output <- getOutput --- context <- setError testContext (VarNameError "var") --- assertEqual "write var fail" context exitContext --- assertEqual "write var fail" [] output --- --- (testContext0, getOutput) <- initTestContext ["123"] --- testContext <- setVar testContext0 "var" 123 --- exitContext <- execute testContext [writeVar] --- output <- getOutput --- assertEqual "write var success" testContext exitContext --- assertEqual "write var success" ["123"] output --- ---unit_executeUnsupported :: IO () ---unit_executeUnsupported = do --- let skip = Skip --- --- exitContext <- execute empty [skip] --- context <- setError empty UnsupportedError --- assertEqual "unsupported" context exitContext --- ---unit_executeRead :: IO () ---unit_executeRead = do --- let readVar = Read "var" --- --- (testContext, getOutput) <- initTestContext ["123"] --- exitContext <- execute testContext [readVar] --- output <- getOutput --- context <- setVar testContext "var" 123 --- assertEqual "read success" context exitContext --- assertEqual "read success" [] output --- --- (testContext, getOutput) <- initTestContext ["fds"] --- exitContext <- execute testContext [readVar] --- output <- getOutput --- context <- setError testContext (InvalidInputError "fds") --- assertEqual "read failure" context exitContext --- assertEqual "read failure" [] output + +import Test.Tasty.HUnit (assertEqual, assertBool) +import Statement (Expression(..), Statement (..)) +import qualified Data.Map as Map +import Context (Context(..), setVar, setError, VarContext (..), Buffer(..), newContext) +import Evaluate (evaluateStatements) +import Control.Monad.State ( evalStateT, execStateT ) +import Error (RuntimeError(..)) +import qualified Data.Map as Map +import GHC.IO.Handle (hClose) +import GHC.IO.Handle.FD (stdin) + +checkOutput :: Context -> [String] -> Bool +checkOutput cxt out = Context.output cxt == Buffer out + +checkError :: Context -> RuntimeError -> Bool +checkError cxt err = Context.error cxt == Just err + +unit_executeWrite :: IO () +unit_executeWrite = do + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let contextWithVar = newContext { vars = [VarContext (Map.fromList [("var", 123)])] } + + hClose stdin + + exitContext <- execStateT (evaluateStatements [writeConst]) newContext + assertBool "write const" $ checkOutput exitContext ["1"] + + exitContext <- execStateT (evaluateStatements [writeVar]) contextWithVar + assertBool "write var" $ checkOutput exitContext ["123"] + + exitContext <- execStateT (evaluateStatements [writeVar]) newContext + assertBool "write var failure" $ checkOutput exitContext [] + assertBool "write var failure" $ checkError exitContext (VarNotFound "var") + +unit_executeRead :: IO () +unit_executeRead = do + let readVar = Read "var" + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let contextWithInput = newContext { input = Buffer ["123"]} + + hClose stdin + + exitContext <- execStateT (evaluateStatements [readVar, writeVar]) contextWithInput + assertBool "read var success" $ checkOutput exitContext ["123"] + + exitContext <- execStateT (evaluateStatements [readVar]) newContext + assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF + From f953554edd7faec3bdc2835e6a264e1031997640 Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 22 Dec 2022 19:04:37 +0100 Subject: [PATCH 45/75] fix other functionality --- src/Context.hs | 27 ++++++++++++++++++++++++--- src/Evaluate.hs | 4 +++- test/Test/Execute.hs | 12 +++++++----- 3 files changed, 34 insertions(+), 9 deletions(-) diff --git a/src/Context.hs b/src/Context.hs index ae59a4a..4fd16b1 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -6,8 +6,11 @@ module Context where import qualified Data.Map as Map import Error (RuntimeError (FunctionNotFound, VarNotFound)) import Statement (Function (..)) -import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) import Control.Monad.State +import Data.Foldable (Foldable(fold)) +import Data.Maybe (fromJust, isJust) +import GHC.IO.Handle (hIsOpen) newtype FunContext = FunContext {funContext :: Map.Map String Function} deriving (Show, Eq) @@ -40,7 +43,8 @@ data Context = Context vars :: [VarContext], error :: Maybe RuntimeError, input :: Buffer, - output :: Buffer + output :: Buffer, + flushEnabled :: Bool } deriving (Show) @@ -58,7 +62,8 @@ newContext = vars = [emptyVarContext], Context.error = Nothing, input = Buffer [], - output = Buffer [] + output = Buffer [], + flushEnabled = True } getHelper :: String -> [Map.Map String a] -> Maybe a @@ -115,6 +120,14 @@ popInput = do put $ cxt { input = buf } return ret +popOutput :: MaybeT (StateT Context IO) String +popOutput = do + cxt <- get + let (buf, h) = pop $ output cxt + ret <- maybe mzero return h + put $ cxt { output = buf } + return ret + setFun :: String -> Function -> Context -> Context setFun name f ctx = @@ -131,3 +144,11 @@ loadFunStack (Function args _ _) values ctx = ctx {funs = emptyFunContext : funs unloadFunStack :: Context -> Context unloadFunStack ctx = ctx {funs = (tail . funs) ctx, vars = (tail . vars) ctx} + +flush :: StateT Context IO () +flush = do + + out <- runMaybeT popOutput + when (isJust out) $ do + lift $ putStrLn $ fromJust out + flush diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 90d7af2..3213de9 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -2,7 +2,7 @@ module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression, evaluateList) where -import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack, popInput, setErrorT, pushOutput) +import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack, popInput, setErrorT, pushOutput, flush) import Control.Composition import Control.Monad.State import Statement (Expression (..), Function (..), Operations (..), Statement (..)) @@ -137,4 +137,6 @@ evaluateStatements :: [Statement] -> StateT Context IO () evaluateStatements [] = pure () evaluateStatements (x : xs) = do evaluateOneStatement x + cxt <- get + when (flushEnabled cxt) flush evaluateStatements xs diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index 7dda55a..b6c9151 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -18,21 +18,23 @@ checkOutput cxt out = Context.output cxt == Buffer out checkError :: Context -> RuntimeError -> Bool checkError cxt err = Context.error cxt == Just err +noFlushContext = newContext { flushEnabled = False } + unit_executeWrite :: IO () unit_executeWrite = do let writeConst = Write (Const 1) let writeVar = Write (VariableName "var") - let contextWithVar = newContext { vars = [VarContext (Map.fromList [("var", 123)])] } + let contextWithVar = noFlushContext { vars = [VarContext (Map.fromList [("var", 123)])] } hClose stdin - exitContext <- execStateT (evaluateStatements [writeConst]) newContext + exitContext <- execStateT (evaluateStatements [writeConst]) noFlushContext assertBool "write const" $ checkOutput exitContext ["1"] exitContext <- execStateT (evaluateStatements [writeVar]) contextWithVar assertBool "write var" $ checkOutput exitContext ["123"] - exitContext <- execStateT (evaluateStatements [writeVar]) newContext + exitContext <- execStateT (evaluateStatements [writeVar]) noFlushContext assertBool "write var failure" $ checkOutput exitContext [] assertBool "write var failure" $ checkError exitContext (VarNotFound "var") @@ -41,13 +43,13 @@ unit_executeRead = do let readVar = Read "var" let writeConst = Write (Const 1) let writeVar = Write (VariableName "var") - let contextWithInput = newContext { input = Buffer ["123"]} + let contextWithInput = noFlushContext { input = Buffer ["123"]} hClose stdin exitContext <- execStateT (evaluateStatements [readVar, writeVar]) contextWithInput assertBool "read var success" $ checkOutput exitContext ["123"] - exitContext <- execStateT (evaluateStatements [readVar]) newContext + exitContext <- execStateT (evaluateStatements [readVar]) noFlushContext assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF From e54ea02b989a7d908ca8b6800e580ac306067998 Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 22 Dec 2022 13:04:20 +0100 Subject: [PATCH 46/75] Tests for function declaration parser --- test/Test/Parsers.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 3dc7f74..8b48da5 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -200,3 +200,24 @@ unit_expressionOrStatement = do Left _ -> True Right _ -> False +unit_functionsDeclarations :: IO () +unit_functionsDeclarations = do + let success = parseSuccessful functionDeclaration + let fail = parseFailed functionDeclaration + + assertBool "Simple function without return" $ success "def f() {skip}" [FunctionDeclaration "f" (Function [] [Skip] Nothing)] + assertBool "Function with empty body" $ fail "def f() {}" + assertBool "Wierd spaces" $ success "def f ( ) { skip }" [FunctionDeclaration "f" (Function [] [Skip] Nothing)] + assertBool "Multiline functions" $ success "def f() \n {\n skip \n}" [FunctionDeclaration "f" (Function [] [Skip] Nothing)] + assertBool "A lot of statements inside body" $ success "def f() { x := 1; skip }" [FunctionDeclaration "f" (Function [] [Let "x" (Const 1), Skip] Nothing)] + assertBool "Long function name" $ success "def ffffffffffffffffffffffffff() { skip }" [FunctionDeclaration "ffffffffffffffffffffffffff" (Function [] [Skip] Nothing)] + + assertBool "without def" $ fail "f() {skip}" + assertBool "without braces" $ fail "def f { skip }" + + assertBool "With return expression" $ success "def f() { skip } return 2" [FunctionDeclaration "f" (Function [] [Skip] (Just $ Const 2))] + assertBool "With params" $ success "def f(a, b, c, d, e, f) { skip }" [FunctionDeclaration "f" (Function ["a", "b", "c", "d", "e", "f"] [Skip] Nothing)] + assertBool "Identity function" $ success "def f(x) { skip } return x" [FunctionDeclaration "f" (Function ["x"] [Skip] (Just $ VariableName "x"))] + + assertBool "Wierd argument name" $ fail "def f(asdas d sda ) {skip}" + assertBool "Unclosed comma" $ fail "def f(a,) {skip}" From 1b289b3c145aee6ce8de172404e0d653c6f98793 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 23 Dec 2022 10:55:14 +0100 Subject: [PATCH 47/75] Fun functions tests --- src/Evaluate.hs | 4 +- src/Grammar.hs | 1 + test/Test/Execute.hs | 108 ++++++++++++++++++++++++++++++++----------- 3 files changed, 83 insertions(+), 30 deletions(-) diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 3213de9..281a187 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -92,8 +92,8 @@ evaluateOneStatement (While expression statements) = do value <- runMaybeT $ evaluateExpression expression case value of Just val - | toBool val -> pure () - | otherwise -> evaluateStatements statements + | toBool val -> evaluateStatements statements + | otherwise -> pure () Nothing -> pure () evaluateOneStatement (If expression trueStatements falseStatements) = do diff --git a/src/Grammar.hs b/src/Grammar.hs index 6ad9559..4cb0949 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -155,6 +155,7 @@ statement = readVariable, skip, try funCallStatement, + functionDeclaration, letVariable ] diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index b6c9151..fca559a 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -1,16 +1,15 @@ -{-# LANGUAGE LambdaCase #-} module Test.Execute where -import Test.Tasty.HUnit (assertEqual, assertBool) -import Statement (Expression(..), Statement (..)) +import Context (Buffer (..), Context (..), VarContext (..), newContext) +import Control.Monad.State (execStateT) import qualified Data.Map as Map -import Context (Context(..), setVar, setError, VarContext (..), Buffer(..), newContext) +import Error (RuntimeError (..)) import Evaluate (evaluateStatements) -import Control.Monad.State ( evalStateT, execStateT ) -import Error (RuntimeError(..)) -import qualified Data.Map as Map import GHC.IO.Handle (hClose) import GHC.IO.Handle.FD (stdin) +import Statement (Expression (..), Operations (..), Statement (..)) +import Test.Tasty.HUnit (assertBool) +import Execute(run) checkOutput :: Context -> [String] -> Bool checkOutput cxt out = Context.output cxt == Buffer out @@ -18,38 +17,91 @@ checkOutput cxt out = Context.output cxt == Buffer out checkError :: Context -> RuntimeError -> Bool checkError cxt err = Context.error cxt == Just err -noFlushContext = newContext { flushEnabled = False } +noFlushContext :: Context +noFlushContext = newContext {flushEnabled = False} unit_executeWrite :: IO () unit_executeWrite = do - let writeConst = Write (Const 1) - let writeVar = Write (VariableName "var") - let contextWithVar = noFlushContext { vars = [VarContext (Map.fromList [("var", 123)])] } + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let contextWithVar = noFlushContext {vars = [VarContext (Map.fromList [("var", 123)])]} - hClose stdin + hClose stdin - exitContext <- execStateT (evaluateStatements [writeConst]) noFlushContext - assertBool "write const" $ checkOutput exitContext ["1"] + exitContext <- execStateT (evaluateStatements [writeConst]) noFlushContext + assertBool "write const" $ checkOutput exitContext ["1"] - exitContext <- execStateT (evaluateStatements [writeVar]) contextWithVar - assertBool "write var" $ checkOutput exitContext ["123"] + exitContext <- execStateT (evaluateStatements [writeVar]) contextWithVar + assertBool "write var" $ checkOutput exitContext ["123"] - exitContext <- execStateT (evaluateStatements [writeVar]) noFlushContext - assertBool "write var failure" $ checkOutput exitContext [] - assertBool "write var failure" $ checkError exitContext (VarNotFound "var") + exitContext <- execStateT (evaluateStatements [writeVar]) noFlushContext + assertBool "write var failure" $ checkOutput exitContext [] + assertBool "write var failure" $ checkError exitContext (VarNotFound "var") unit_executeRead :: IO () unit_executeRead = do - let readVar = Read "var" - let writeConst = Write (Const 1) - let writeVar = Write (VariableName "var") - let contextWithInput = noFlushContext { input = Buffer ["123"]} + let readVar = Read "var" + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let contextWithInput = noFlushContext {input = Buffer ["123"]} + + hClose stdin + + exitContext <- execStateT (evaluateStatements [readVar, writeVar]) contextWithInput + assertBool "read var success" $ checkOutput exitContext ["123"] - hClose stdin + exitContext <- execStateT (evaluateStatements [readVar]) noFlushContext + assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF - exitContext <- execStateT (evaluateStatements [readVar, writeVar]) contextWithInput - assertBool "read var success" $ checkOutput exitContext ["123"] +unit_basicWhileTest :: IO () +unit_basicWhileTest = do + -- let code = "x := 1\n" ++ "write x + 10\n" ++ "while x > 0 do write x; x := x - 1" ++ "write x" + let code = + [ Let "x" (Const 1), + Write $ Application $ Addition (VariableName "x") (Const 10), + While + (Application $ Greater (VariableName "x") (Const 0)) + [Write $ VariableName "x", Let "x" (Application $ Subtraction (VariableName "x") (Const 1))], + Write $ VariableName "x" + ] + let context = noFlushContext {input = Buffer []} - exitContext <- execStateT (evaluateStatements [readVar]) noFlushContext - assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF + hClose stdin + exitContext <- execStateT (evaluateStatements code) context + assertBool "test successfull" $ checkOutput exitContext ["11", "1", "0"] +unit_functions :: IO () +unit_functions = do + let code = + [ + "def f() { write 1 } return 2", + "f()", + "f()", + "write f() + 2", + "x := 1", + "def g() { write x }", + "g()", + "def h() { y := x; write y; write x; x := x + 10; write x } return x", + "write h()", + "write x", + "def sum(a, b) { skip } return a + b", + "write sum(3, 4)" + ] + let context = noFlushContext {input = Buffer []} + + hClose stdin + evaluated <- execStateT (run code) context + assertBool "function declaration works" $ checkOutput evaluated [ + "1", + "1", + "1", + "4", + "1", + "1", + "1", + "11", + "11", + "1", + "7" + ] + From 7d7ece2aeec5939f25298a615cd79634140100eb Mon Sep 17 00:00:00 2001 From: khbminus Date: Tue, 27 Dec 2022 12:27:15 +0100 Subject: [PATCH 48/75] Basic graph transformation. I dunno is this working --- L-static-analyzer.cabal | 5 +++ package.yaml | 2 ++ src/Analysis/AstToIr.hs | 76 +++++++++++++++++++++++++++++++++++++++++ src/Analysis/IR.hs | 44 ++++++++++++++++++++++++ stack.yaml | 2 ++ 5 files changed, 129 insertions(+) create mode 100644 src/Analysis/AstToIr.hs create mode 100644 src/Analysis/IR.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 47ad7f5..631db09 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -25,6 +25,8 @@ source-repository head library exposed-modules: + Analysis.AstToIr + Analysis.IR Console ConsoleParser Context @@ -42,6 +44,7 @@ library base >=4.7 && <5 , composition-prelude , containers + , hoopl , megaparsec , mtl , optparse-applicative @@ -61,6 +64,7 @@ executable L-static-analyzer-exe , base >=4.7 && <5 , composition-prelude , containers + , hoopl , megaparsec , mtl , optparse-applicative @@ -88,6 +92,7 @@ test-suite L-static-analyzer-test , composition-prelude , containers , hedgehog + , hoopl , hspec , hspec-megaparsec , megaparsec diff --git a/package.yaml b/package.yaml index 93ae697..6831d26 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - megaparsec - parser-combinators - mtl +- hoopl ghc-options: - -Wall @@ -45,6 +46,7 @@ library: - containers - optparse-applicative - transformers + - megaparsec executables: L-static-analyzer-exe: diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs new file mode 100644 index 0000000..b6b63be --- /dev/null +++ b/src/Analysis/AstToIr.hs @@ -0,0 +1,76 @@ +module Analysis.AstToIr where + +import qualified Statement as A -- AST +import qualified Analysis.IR as I +import Compiler.Hoopl hiding ((<*>)) +import qualified Compiler.Hoopl as H ((<*>)) + +astToIR :: String -> A.Function -> I.M I.Proc +astToIR name (A.Function args body _) = do + (entry, body') <- toBody body + return $ I.Proc {I.name = name, I.args = args, I.body = body', I.entry = entry} + +toBody :: [A.Statement] -> I.M (Label, Graph I.Instruction C C) +toBody bs = do + let blocks = splitIntoBlocks bs + (lastLabel, lastGraph) <- lastBlock + (fullLabel, fullGraph) <- fullBlockTransform blocks lastLabel + return (fullLabel, fullGraph |*><*| lastGraph) + +lastBlock :: I.M (Label, Graph I.Instruction C C) +lastBlock = do + label <- freshLabel + return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return [])) + +splitIntoBlocks :: [A.Statement] -> [([A.Statement], Maybe A.Statement)] +splitIntoBlocks xs = splitHelper xs [] [] + where + splitHelper :: [A.Statement] -> [A.Statement] -> [([A.Statement], Maybe A.Statement)] -> [([A.Statement], Maybe A.Statement)] + splitHelper [] accBlock acc = acc ++ [(accBlock, Nothing)] + splitHelper (x : xs) accBlock acc = case x of + y@A.If {} -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) + y@(A.While _ _) -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) + y -> splitHelper xs (accBlock ++ [y]) acc + +blockTransform :: ([A.Statement], Maybe A.Statement) -> Label -> I.M (Label, Graph I.Instruction C C) +blockTransform (code, last) next = do + label <- freshLabel + let ms = map toMid code + (last', lastGraph) <- toLast last next + let graph = mkFirst (I.Label label) H.<*> mkMiddles ms H.<*> mkLast last' + return (label, graph |*><*| lastGraph) + +fullBlockTransform :: [([A.Statement], Maybe A.Statement)] -> Label -> I.M (Label, Graph I.Instruction C C) +fullBlockTransform [] _ = error "Can't process empty body" +fullBlockTransform [x] next = blockTransform x next +fullBlockTransform (x : xs) next = do + (realNextLabel, nextGraph) <- fullBlockTransform xs next + (nowLabel, nowGraph) <- blockTransform x realNextLabel + return (nowLabel, nowGraph |*><*| nextGraph) + +toLast :: Maybe A.Statement -> Label -> I.M (I.Instruction O C, Graph I.Instruction C C) +toLast Nothing next = return (I.Goto next, emptyClosedGraph) +toLast (Just (A.If e t f)) next = do + let trueBlocks = splitIntoBlocks t + let falseBlocks = splitIntoBlocks f + (trueLabel, trueGraph) <- fullBlockTransform trueBlocks next + (falseLabel, falseGraph) <- fullBlockTransform falseBlocks next + return (I.If e trueLabel falseLabel, trueGraph |*><*| falseGraph) +toLast (Just (A.While e s)) next = do + let blocks = splitIntoBlocks s + whileLabel <- freshLabel + (sLabel, sGraph) <- fullBlockTransform blocks whileLabel + let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.If e sLabel next) + return (I.Goto whileLabel, whileGraph |*><*| sGraph) +toLast _ _ = error "invalid last" + + +toMid :: A.Statement -> I.Instruction O O +toMid (A.Let v e) = I.Let v e +toMid (A.FunctionCallStatement _ _) = undefined -- FIXME +toMid (A.FunctionDeclaration _ _) = undefined -- FIXME +toMid (A.Write expr) = I.Write expr +toMid (A.Read expr) = I.Read expr +toMid A.Skip = I.Skip +toMid (A.While _ _) = error "can't be right here" +toMid A.If {} = error "can't be right here" \ No newline at end of file diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs new file mode 100644 index 0000000..55d6332 --- /dev/null +++ b/src/Analysis/IR.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} + +module Analysis.IR where +import Compiler.Hoopl +import Statement (Expression(..)) + +type M = CheckingFuelMonad SimpleUniqueMonad -- Magic + +data Proc = Proc { name :: String, args :: [String], entry :: Label, body :: Graph Instruction C C } + +data Instruction e x where + Label :: Label -> Instruction C O + Let :: String -> Expression -> Instruction O O + If :: Expression -> Label -> Label -> Instruction O C -- if (!expr) goto + Return :: [Expression] -> Instruction O C + Goto :: Label -> Instruction O C + Write :: Expression -> Instruction O O + Read :: String -> Instruction O O + Skip :: Instruction O O + -- Call :: FIXME + +instance NonLocal Instruction where + entryLabel :: Instruction C x -> Label + entryLabel (Label l) = l + entryLabel _ = error "Entry label for not label" -- make GHC happy + + successors (Goto l) = [l] + successors (If _ t f) = [t, f] + successors _ = error "Successor of not sucessorable thing" -- make GHC happy + +instance Show (Instruction e x) where + show (Label l) = show l ++ ": " + show (Let x expr) = indent $ show x ++ " := " ++ show expr + show (If e t f) = indent $ "if " ++ show e ++ "then goto " ++ show t ++ "else goto " ++ show f + show (Goto l) = indent $ "goto" ++ show l + show (Write expr) = indent $ "write " ++ show expr + show (Read var) = indent $ "read " ++ var + show Skip = indent "Skip" + show (Return expr) = indent $ "return" ++ show expr + + +indent :: String -> String +indent x = " " ++ x \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 47eb1c5..e905565 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,6 +41,8 @@ packages: # extra-deps: - composition-prelude-3.0.0.2@sha256:1ffed216bd28d810fce0b5be83a661e2a892696d73b3f8de5c0f5edb9b5f0090,1216 + - git: https://github.com/tgiannak/hoopl + commit: 287b2192be5729a4e302518d528fa1f86cbdc400 # Override default flag values for local packages and extra-deps # flags: {} From efcfbbe7dd3a4e6c7d8b2273f337cdd34d1f0191 Mon Sep 17 00:00:00 2001 From: khbminus Date: Tue, 27 Dec 2022 15:27:24 +0100 Subject: [PATCH 49/75] some show changes --- config.yaml | 1 + src/Analysis/AstToIr.hs | 2 +- src/Analysis/IR.hs | 8 ++--- src/Evaluate.hs | 34 +++++++++---------- src/Grammar.hs | 29 +++++++--------- src/Statement.hs | 75 +++++++++++++++++++++++++++++++---------- test/Test/Execute.hs | 6 ++-- test/Test/Parsers.hs | 20 +++++------ 8 files changed, 105 insertions(+), 70 deletions(-) create mode 100644 config.yaml diff --git a/config.yaml b/config.yaml new file mode 100644 index 0000000..17f7a43 --- /dev/null +++ b/config.yaml @@ -0,0 +1 @@ +allow-newer: true diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index b6b63be..8404f35 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -1,4 +1,4 @@ -module Analysis.AstToIr where +module Analysis.AstToIr(astToIR) where import qualified Statement as A -- AST import qualified Analysis.IR as I diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index 55d6332..2fa09c5 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} -module Analysis.IR where +module Analysis.IR(Instruction(..), Proc(..), M) where import Compiler.Hoopl import Statement (Expression(..)) @@ -32,12 +32,12 @@ instance NonLocal Instruction where instance Show (Instruction e x) where show (Label l) = show l ++ ": " show (Let x expr) = indent $ show x ++ " := " ++ show expr - show (If e t f) = indent $ "if " ++ show e ++ "then goto " ++ show t ++ "else goto " ++ show f - show (Goto l) = indent $ "goto" ++ show l + show (If e t f) = indent $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f + show (Goto l) = indent $ "goto " ++ show l show (Write expr) = indent $ "write " ++ show expr show (Read var) = indent $ "read " ++ var show Skip = indent "Skip" - show (Return expr) = indent $ "return" ++ show expr + show (Return expr) = indent $ "return " ++ show expr indent :: String -> String diff --git a/src/Evaluate.hs b/src/Evaluate.hs index 281a187..eca169f 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -37,27 +37,25 @@ evaluateExpression (FunctionCall name argumentValues) = do modify unloadFunStack return returnValue -evaluateExpression (Application op') = do - let (x, y, op) = unpack op' +evaluateExpression (Application op x y) = do x' <- evaluateExpression x y' <- evaluateExpression y - return $ op x' y' + return $ unpack op x' y' where - -- FIXME: fix that crappy design - unpack :: Operations -> (Expression, Expression, Int -> Int -> Int) - unpack (Addition lft rgt) = (lft, rgt, (+)) - unpack (Subtraction lft rgt) = (lft, rgt, (-)) - unpack (Division lft rgt) = (lft, rgt, div) - unpack (Multiplication lft rgt) = (lft, rgt, (*)) - unpack (Modulo lft rgt) = (lft, rgt, mod) - unpack (Equals lft rgt) = (lft, rgt, fromBool .* (==)) - unpack (NotEquals lft rgt) = (lft, rgt, fromBool .* (/=)) - unpack (Greater lft rgt) = (lft, rgt, fromBool .* (>)) - unpack (GreaterOrEquals lft rgt) = (lft, rgt, fromBool .* (>=)) - unpack (Less lft rgt) = (lft, rgt, fromBool .* (<)) - unpack (LessOrEquals lft rgt) = (lft, rgt, fromBool .* (<=)) - unpack (LazyAnd lft rgt) = (lft, rgt, lazyAnd) - unpack (LazyOr lft rgt) = (lft, rgt, lazyOr) + unpack :: Operations -> (Int -> Int -> Int) + unpack Addition = (+) + unpack Subtraction = (-) + unpack Division = div + unpack Multiplication = (*) + unpack Modulo = mod + unpack Equals = fromBool .* (==) + unpack NotEquals = fromBool .* (/=) + unpack Greater = fromBool .* (>) + unpack GreaterOrEquals = fromBool .* (>=) + unpack Less = fromBool .* (<) + unpack LessOrEquals = fromBool .* (<=) + unpack LazyAnd = lazyAnd + unpack LazyOr = lazyOr lazyAnd :: Int -> Int -> Int lazyAnd lft rgt = if lft == 0 then 0 else boolToInt rgt diff --git a/src/Grammar.hs b/src/Grammar.hs index 4cb0949..4c68dc5 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -58,32 +58,29 @@ expressionTerm = expressionOperationsTable :: [[Operator Parser Expression]] expressionOperationsTable = - [ [ binary "*" $ compose Multiplication, - binary "/" $ compose Division, - binary "%" $ compose Modulo + [ [ binary "*" $ Application Multiplication, + binary "/" $ Application Division, + binary "%" $ Application Modulo ], - [ binary "+" $ compose Addition, - binary "-" $ compose Subtraction + [ binary "+" $ Application Addition, + binary "-" $ Application Subtraction ], - [ binary "==" $ compose Equals, - binary "!=" $ compose NotEquals, - binary "<" $ compose Less, - binary "<=" $ compose LessOrEquals, - binary ">=" $ compose GreaterOrEquals, - binary ">" $ compose Greater + [ binary "==" $ Application Equals, + binary "!=" $ Application NotEquals, + binary "<" $ Application Less, + binary "<=" $ Application LessOrEquals, + binary ">=" $ Application GreaterOrEquals, + binary ">" $ Application Greater ], - [ binary "&&" $ compose LazyAnd + [ binary "&&" $ Application LazyAnd ], - [ binary "||" $ compose LazyOr + [ binary "||" $ Application LazyOr ] ] where binary :: String -> (Expression -> Expression -> Expression) -> Operator Parser Expression binary name f = InfixL (f <$ symbol name) - compose :: (Expression -> Expression -> Operations) -> Expression -> Expression -> Expression - compose f a b = Application $ f a b - expression :: Parser Expression expression = makeExprParser expressionTerm expressionOperationsTable diff --git a/src/Statement.hs b/src/Statement.hs index b536b29..10b3c78 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -1,27 +1,52 @@ module Statement where data Operations - = Addition Expression Expression - | Subtraction Expression Expression - | Multiplication Expression Expression - | Division Expression Expression - | Modulo Expression Expression - | Equals Expression Expression - | NotEquals Expression Expression - | Greater Expression Expression - | GreaterOrEquals Expression Expression - | Less Expression Expression - | LessOrEquals Expression Expression - | LazyAnd Expression Expression - | LazyOr Expression Expression - deriving (Eq, Show) + = Addition + | Subtraction + | Multiplication + | Division + | Modulo + | Equals + | NotEquals + | Greater + | GreaterOrEquals + | Less + | LessOrEquals + | LazyAnd + | LazyOr + deriving (Eq) + +instance Show Operations where + show Addition = "+" + show Subtraction = "-" + show Multiplication = "*" + show Division = "/" + show Modulo = "%" + show Equals = "==" + show NotEquals = "!=" + show Greater = ">" + show Less = "<" + show GreaterOrEquals = ">=" + show LessOrEquals = "<=" + show LazyAnd = "&&" + show LazyOr = "||" data Expression = FunctionCall String [Expression] | VariableName String | Const Int - | Application Operations - deriving (Show, Eq) + | Application Operations Expression Expression + deriving (Eq) + +instance Show Expression where + show (FunctionCall name args) = name ++ "(" ++ show args ++ ")" + show (VariableName x) = x + show (Const x) = show x + show (Application op l r) = parens l ++ " " ++ show op ++ " " ++ parens r + where + parens :: Expression -> String + parens (Application op l r) = "(" ++ show (Application op l r) ++ ")" + parens x = show x data Statement = Let String Expression @@ -32,9 +57,23 @@ data Statement | While Expression [Statement] | If Expression [Statement] [Statement] | Skip - deriving (Show, Eq) + deriving (Eq) + +instance Show Statement where + show (Let x expr) = x ++ " := " ++ show expr + show (FunctionCallStatement name args) = name ++ "(" ++ show args ++ ")" + show (FunctionDeclaration name f) = "def " ++ name ++ show f + show (Write x) = "write " ++ show x + show (Read x) = "read " ++ x + show (While e s) = "while (" ++ show e ++ ") {" ++ show s ++ "}" + show (If e t f) = "If " ++ show e ++ " then " ++ show t ++ " else " ++ show f + show Skip = "skip" + +data Function = Function [String] [Statement] (Maybe Expression) deriving (Eq) -data Function = Function [String] [Statement] (Maybe Expression) deriving (Show, Eq) +instance Show Function where + show (Function args body Nothing) = "(" ++ show args ++ ") {" ++ show body ++ "}" + show (Function args body (Just ret)) = "(" ++ show args ++ ") {" ++ show body ++ "} return" ++ show ret reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index fca559a..73de317 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -58,10 +58,10 @@ unit_basicWhileTest = do -- let code = "x := 1\n" ++ "write x + 10\n" ++ "while x > 0 do write x; x := x - 1" ++ "write x" let code = [ Let "x" (Const 1), - Write $ Application $ Addition (VariableName "x") (Const 10), + Write $ Application Addition (VariableName "x") (Const 10), While - (Application $ Greater (VariableName "x") (Const 0)) - [Write $ VariableName "x", Let "x" (Application $ Subtraction (VariableName "x") (Const 1))], + (Application Greater (VariableName "x") (Const 0)) + [Write $ VariableName "x", Let "x" (Application Subtraction (VariableName "x") (Const 1))], Write $ VariableName "x" ] let context = noFlushContext {input = Buffer []} diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 8b48da5..d24c122 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -49,13 +49,13 @@ unit_expr = do assertBool "simple expression" $ succExpr "1" (Const 1) assertBool "simple with parens" $ succExpr "(1)" (Const 1) - assertBool "operations works fine" $ succExpr "1 + 3" (Application $ Addition (Const 1) (Const 3)) + assertBool "operations works fine" $ succExpr "1 + 3" (Application Addition (Const 1) (Const 3)) assertBool "precedence works fine" $ succExpr "1 * 2 + 3" - ( Application $ + ( Application Addition - ( Application $ + ( Application Multiplication (Const 1) (Const 2) @@ -78,14 +78,14 @@ unit_let = do "x := y % 4 + 2 * 3" [ Let "x" - ( Application $ + ( Application Addition - ( Application $ + ( Application Modulo (VariableName "y") (Const 4) ) - ( Application $ + ( Application Multiplication (Const 2) (Const 3) @@ -106,7 +106,7 @@ unit_let = do VariableName "second", VariableName "third", Const 1, - Application $ Addition (Const 2) (Const 3) + Application Addition (Const 2) (Const 3) ] ) ] @@ -121,7 +121,7 @@ unit_while = do success "while 1 + 2 do x := x" [ While - (Application $ Addition (Const 1) (Const 2)) + (Application Addition (Const 1) (Const 2)) [Let "x" (VariableName "x")] ] @@ -167,10 +167,10 @@ unit_statement = do success "write x + 2 * 3" [ Write $ - Application $ + Application Addition (VariableName "x") - ( Application $ + ( Application Multiplication (Const 2) (Const 3) From 06b4d104e0ee4bca197edfe8973f7c8f9a72dd17 Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 28 Dec 2022 15:32:41 +0100 Subject: [PATCH 50/75] Reformatrd AstToIR, added function support --- src/Analysis/AstToIr.hs | 103 ++++++++++++++++++++++++++++++++-------- src/Analysis/IR.hs | 27 ++++++----- 2 files changed, 97 insertions(+), 33 deletions(-) diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index 8404f35..0c6567d 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -1,26 +1,38 @@ -module Analysis.AstToIr(astToIR) where +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} +module Analysis.AstToIr(astToIR, LabelMap) where -import qualified Statement as A -- AST -import qualified Analysis.IR as I -import Compiler.Hoopl hiding ((<*>)) +import Compiler.Hoopl hiding ((<*>), LabelMap) import qualified Compiler.Hoopl as H ((<*>)) +import qualified Data.Map as M +import qualified Statement as A -- AST +import qualified Analysis.IR as I +import Control.Monad ( ap, liftM ) -astToIR :: String -> A.Function -> I.M I.Proc -astToIR name (A.Function args body _) = do +-- astToIR transforming file with functions to IR Graph +-- It ignores code that not in function +astToIR :: [A.Statement] -> I.M (LabelMap, [I.Proc]) +astToIR code = run $ do + mapM getFunction (filter isFunctionDeclaration code) + +getFunction :: A.Statement -> LabelMapM I.Proc +getFunction (A.FunctionDeclaration name (A.Function args body _)) = do (entry, body') <- toBody body + putLabel name entry return $ I.Proc {I.name = name, I.args = args, I.body = body', I.entry = entry} +getFunction _ = error "only function declaration are supported" -toBody :: [A.Statement] -> I.M (Label, Graph I.Instruction C C) -toBody bs = do - let blocks = splitIntoBlocks bs +toBody :: [A.Statement] -> LabelMapM (Label, Graph I.Instruction C C) +toBody body = do + let blocks = splitIntoBlocks body (lastLabel, lastGraph) <- lastBlock (fullLabel, fullGraph) <- fullBlockTransform blocks lastLabel return (fullLabel, fullGraph |*><*| lastGraph) -lastBlock :: I.M (Label, Graph I.Instruction C C) +lastBlock :: LabelMapM (Label, Graph I.Instruction C C) lastBlock = do - label <- freshLabel - return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return [])) + label <- newLabel + return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return Nothing)) splitIntoBlocks :: [A.Statement] -> [([A.Statement], Maybe A.Statement)] splitIntoBlocks xs = splitHelper xs [] [] @@ -32,15 +44,15 @@ splitIntoBlocks xs = splitHelper xs [] [] y@(A.While _ _) -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) y -> splitHelper xs (accBlock ++ [y]) acc -blockTransform :: ([A.Statement], Maybe A.Statement) -> Label -> I.M (Label, Graph I.Instruction C C) +blockTransform :: ([A.Statement], Maybe A.Statement) -> Label -> LabelMapM (Label, Graph I.Instruction C C) blockTransform (code, last) next = do - label <- freshLabel + label <- newLabel let ms = map toMid code (last', lastGraph) <- toLast last next let graph = mkFirst (I.Label label) H.<*> mkMiddles ms H.<*> mkLast last' return (label, graph |*><*| lastGraph) -fullBlockTransform :: [([A.Statement], Maybe A.Statement)] -> Label -> I.M (Label, Graph I.Instruction C C) +fullBlockTransform :: [([A.Statement], Maybe A.Statement)] -> Label -> LabelMapM (Label, Graph I.Instruction C C) fullBlockTransform [] _ = error "Can't process empty body" fullBlockTransform [x] next = blockTransform x next fullBlockTransform (x : xs) next = do @@ -48,7 +60,7 @@ fullBlockTransform (x : xs) next = do (nowLabel, nowGraph) <- blockTransform x realNextLabel return (nowLabel, nowGraph |*><*| nextGraph) -toLast :: Maybe A.Statement -> Label -> I.M (I.Instruction O C, Graph I.Instruction C C) +toLast :: Maybe A.Statement -> Label -> LabelMapM (I.Instruction O C, Graph I.Instruction C C) toLast Nothing next = return (I.Goto next, emptyClosedGraph) toLast (Just (A.If e t f)) next = do let trueBlocks = splitIntoBlocks t @@ -58,19 +70,70 @@ toLast (Just (A.If e t f)) next = do return (I.If e trueLabel falseLabel, trueGraph |*><*| falseGraph) toLast (Just (A.While e s)) next = do let blocks = splitIntoBlocks s - whileLabel <- freshLabel + whileLabel <- newLabel (sLabel, sGraph) <- fullBlockTransform blocks whileLabel let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.If e sLabel next) return (I.Goto whileLabel, whileGraph |*><*| sGraph) +toLast (Just (A.FunctionCallStatement name args)) _ = do + label <- getLabel name + return (I.Call name args label, emptyClosedGraph) -- TODO: It's invalid logic here. Function call should call function and continue execution. toLast _ _ = error "invalid last" toMid :: A.Statement -> I.Instruction O O toMid (A.Let v e) = I.Let v e -toMid (A.FunctionCallStatement _ _) = undefined -- FIXME -toMid (A.FunctionDeclaration _ _) = undefined -- FIXME +toMid (A.FunctionCallStatement _ _) = error "can't be right here" +toMid (A.FunctionDeclaration _ _) = error "Non top-level function declaration is not allowed" -- FIXME toMid (A.Write expr) = I.Write expr toMid (A.Read expr) = I.Read expr toMid A.Skip = I.Skip toMid (A.While _ _) = error "can't be right here" -toMid A.If {} = error "can't be right here" \ No newline at end of file +toMid A.If {} = error "can't be right here" + +run :: LabelMapM a -> I.M (LabelMap, a) +run (LabelMapM f) = f M.empty + +type LabelMap = M.Map String Label +data LabelMapM a = LabelMapM (LabelMap -> I.M (LabelMap, a)) + + +instance Functor LabelMapM where + fmap = liftM + +instance Applicative LabelMapM where + pure x = LabelMapM (\m -> return (m, x)) + (<*>) = ap + +instance Monad LabelMapM where + return = pure + LabelMapM f1 >>= k = LabelMapM (\m -> + do + (m', x) <- f1 m + let (LabelMapM f2) = k x + f2 m' + ) +getLabel :: String -> LabelMapM Label +getLabel name = LabelMapM f + where f m = case M.lookup name m of + Just l -> return (m, l) + Nothing -> do + l <- freshLabel + let m' = M.insert name l m + return (m', l) + +putLabel :: String -> Label -> LabelMapM () +putLabel name label = LabelMapM f + where f m = + do + return (M.insert name label m, ()) + +newLabel :: LabelMapM Label +newLabel = LabelMapM f + where f m = + do + l <- freshLabel + return (m, l) + +isFunctionDeclaration :: A.Statement -> Bool +isFunctionDeclaration (A.FunctionDeclaration _ _ ) = True +isFunctionDeclaration _ = False \ No newline at end of file diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index 2fa09c5..4c64d24 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -10,24 +10,24 @@ type M = CheckingFuelMonad SimpleUniqueMonad -- Magic data Proc = Proc { name :: String, args :: [String], entry :: Label, body :: Graph Instruction C C } data Instruction e x where - Label :: Label -> Instruction C O - Let :: String -> Expression -> Instruction O O - If :: Expression -> Label -> Label -> Instruction O C -- if (!expr) goto - Return :: [Expression] -> Instruction O C - Goto :: Label -> Instruction O C - Write :: Expression -> Instruction O O - Read :: String -> Instruction O O - Skip :: Instruction O O - -- Call :: FIXME + Label :: Label -> Instruction C O + Let :: String -> Expression -> Instruction O O + If :: Expression -> Label -> Label -> Instruction O C + Return :: Maybe Expression -> Instruction O C + Goto :: Label -> Instruction O C + Write :: Expression -> Instruction O O + Read :: String -> Instruction O O + Skip :: Instruction O O + Call :: String -> [Expression] -> Label -> Instruction O C instance NonLocal Instruction where entryLabel :: Instruction C x -> Label entryLabel (Label l) = l - entryLabel _ = error "Entry label for not label" -- make GHC happy successors (Goto l) = [l] successors (If _ t f) = [t, f] - successors _ = error "Successor of not sucessorable thing" -- make GHC happy + successors (Call _ _ l) = [l] + successors (Return _) = [] instance Show (Instruction e x) where show (Label l) = show l ++ ": " @@ -37,8 +37,9 @@ instance Show (Instruction e x) where show (Write expr) = indent $ "write " ++ show expr show (Read var) = indent $ "read " ++ var show Skip = indent "Skip" - show (Return expr) = indent $ "return " ++ show expr - + show (Return Nothing) = indent $ "return" + show (Return (Just x)) = indent $ "return " ++ show x + show (Call name args toLabel) = indent $ "call " ++ name ++ "(" ++ show args ++ " -> " ++ show toLabel indent :: String -> String indent x = " " ++ x \ No newline at end of file From 92c326b9fcfaf5dbd10a0763aa3bddc8f9915202 Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 28 Dec 2022 20:19:24 +0100 Subject: [PATCH 51/75] fixed FunctionCallStatement IR --- src/Analysis/AstToIr.hs | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index 0c6567d..7c69f88 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -42,6 +42,7 @@ splitIntoBlocks xs = splitHelper xs [] [] splitHelper (x : xs) accBlock acc = case x of y@A.If {} -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) y@(A.While _ _) -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) + y@(A.FunctionCallStatement _ _) -> splitHelper xs [] (acc ++ [(accBlock, Just y)]) y -> splitHelper xs (accBlock ++ [y]) acc blockTransform :: ([A.Statement], Maybe A.Statement) -> Label -> LabelMapM (Label, Graph I.Instruction C C) @@ -74,9 +75,7 @@ toLast (Just (A.While e s)) next = do (sLabel, sGraph) <- fullBlockTransform blocks whileLabel let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.If e sLabel next) return (I.Goto whileLabel, whileGraph |*><*| sGraph) -toLast (Just (A.FunctionCallStatement name args)) _ = do - label <- getLabel name - return (I.Call name args label, emptyClosedGraph) -- TODO: It's invalid logic here. Function call should call function and continue execution. +toLast (Just (A.FunctionCallStatement name args)) next = return (I.Call name args next, emptyClosedGraph) toLast _ _ = error "invalid last" @@ -112,14 +111,6 @@ instance Monad LabelMapM where let (LabelMapM f2) = k x f2 m' ) -getLabel :: String -> LabelMapM Label -getLabel name = LabelMapM f - where f m = case M.lookup name m of - Just l -> return (m, l) - Nothing -> do - l <- freshLabel - let m' = M.insert name l m - return (m', l) putLabel :: String -> Label -> LabelMapM () putLabel name label = LabelMapM f From 21411492daae2f3c18c97e351f72a14173bd9afd Mon Sep 17 00:00:00 2001 From: khbminus Date: Wed, 28 Dec 2022 20:19:42 +0100 Subject: [PATCH 52/75] I didn't save... --- src/Analysis/IR.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index 4c64d24..f1d6cd7 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -18,7 +18,7 @@ data Instruction e x where Write :: Expression -> Instruction O O Read :: String -> Instruction O O Skip :: Instruction O O - Call :: String -> [Expression] -> Label -> Instruction O C + Call :: String -> [Expression] -> Label -> Instruction O C -- accidentally should be OC instance NonLocal Instruction where entryLabel :: Instruction C x -> Label From 3588467d1df3c81320d554c2c576801ce6552877 Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 29 Dec 2022 13:03:07 +0200 Subject: [PATCH 53/75] folds --- src/Analysis/OptSupport.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 src/Analysis/OptSupport.hs diff --git a/src/Analysis/OptSupport.hs b/src/Analysis/OptSupport.hs new file mode 100644 index 0000000..4fa1a04 --- /dev/null +++ b/src/Analysis/OptSupport.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} +module Analysis.OptSupport where + +import Statement +import Analysis.IR + +fold_EE :: (a -> Expression -> a) -> a -> Expression -> a +fold_EN :: (a -> Expression -> a) -> a -> Instruction e x -> a + +fold_EE f z e@(Const _) = f z e +fold_EE f z e@(VariableName _) = f z e +fold_EE f z e@(FunctionCall _ exprs) = f (foldl f z exprs) e +fold_EE f z e@(Application _ e1 e2) = + let afterE1 = fold_EE f z e1 + afterE2 = fold_EE f afterE1 e2 + in f afterE2 e + +fold_EN _ z (Label _) = z +fold_EN f z (Let _ e) = f z e +fold_EN f z (If e _ _) = f z e +fold_EN f z (Return es) = maybe z (f z) es +fold_EN _ z (Goto _) = z +fold_EN f z (Write e) = f z e +fold_EN f z (Read e) = z +fold_EN _ z (Skip _) = z +fold_EN f z (Call _ _ es _) = foldl f z es \ No newline at end of file From 783488c1c436a162c788f972df1da82bcec24e07 Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 29 Dec 2022 15:03:24 +0100 Subject: [PATCH 54/75] Added an `While` Last option --- L-static-analyzer.cabal | 1 + src/Analysis/AstToIr.hs | 2 +- src/Analysis/IR.hs | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 631db09..821aa07 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -27,6 +27,7 @@ library exposed-modules: Analysis.AstToIr Analysis.IR + Analysis.IrToAst Console ConsoleParser Context diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index 7c69f88..3ba374f 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -73,7 +73,7 @@ toLast (Just (A.While e s)) next = do let blocks = splitIntoBlocks s whileLabel <- newLabel (sLabel, sGraph) <- fullBlockTransform blocks whileLabel - let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.If e sLabel next) + let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.While e sLabel next) return (I.Goto whileLabel, whileGraph |*><*| sGraph) toLast (Just (A.FunctionCallStatement name args)) next = return (I.Call name args next, emptyClosedGraph) toLast _ _ = error "invalid last" diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index f1d6cd7..4681462 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -18,6 +18,7 @@ data Instruction e x where Write :: Expression -> Instruction O O Read :: String -> Instruction O O Skip :: Instruction O O + While :: Expression -> Label -> Label -> Instruction O C Call :: String -> [Expression] -> Label -> Instruction O C -- accidentally should be OC instance NonLocal Instruction where @@ -28,6 +29,7 @@ instance NonLocal Instruction where successors (If _ t f) = [t, f] successors (Call _ _ l) = [l] successors (Return _) = [] + successors (While _ start next) = [start, next] instance Show (Instruction e x) where show (Label l) = show l ++ ": " @@ -40,6 +42,7 @@ instance Show (Instruction e x) where show (Return Nothing) = indent $ "return" show (Return (Just x)) = indent $ "return " ++ show x show (Call name args toLabel) = indent $ "call " ++ name ++ "(" ++ show args ++ " -> " ++ show toLabel + show (While expr start next) = indent $ "while (" ++ show expr ++ ") goto " ++ show start ++ " after goto " ++ show next indent :: String -> String indent x = " " ++ x \ No newline at end of file From 8ace929d73ed840865ee405d01ba4ba66beb8869 Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 29 Dec 2022 20:33:27 +0200 Subject: [PATCH 55/75] liveness logic --- src/Analysis/IR.hs | 3 ++ src/Analysis/Live.hs | 58 ++++++++++++++++++++++++++++++++++++++ src/Analysis/OptSupport.hs | 26 +++++++++-------- 3 files changed, 75 insertions(+), 12 deletions(-) create mode 100644 src/Analysis/Live.hs diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index f1d6cd7..4681462 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -18,6 +18,7 @@ data Instruction e x where Write :: Expression -> Instruction O O Read :: String -> Instruction O O Skip :: Instruction O O + While :: Expression -> Label -> Label -> Instruction O C Call :: String -> [Expression] -> Label -> Instruction O C -- accidentally should be OC instance NonLocal Instruction where @@ -28,6 +29,7 @@ instance NonLocal Instruction where successors (If _ t f) = [t, f] successors (Call _ _ l) = [l] successors (Return _) = [] + successors (While _ start next) = [start, next] instance Show (Instruction e x) where show (Label l) = show l ++ ": " @@ -40,6 +42,7 @@ instance Show (Instruction e x) where show (Return Nothing) = indent $ "return" show (Return (Just x)) = indent $ "return " ++ show x show (Call name args toLabel) = indent $ "call " ++ name ++ "(" ++ show args ++ " -> " ++ show toLabel + show (While expr start next) = indent $ "while (" ++ show expr ++ ") goto " ++ show start ++ " after goto " ++ show next indent :: String -> String indent x = " " ++ x \ No newline at end of file diff --git a/src/Analysis/Live.hs b/src/Analysis/Live.hs new file mode 100644 index 0000000..6f9cb12 --- /dev/null +++ b/src/Analysis/Live.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +module Analysis.Live (liveLattice, liveness, deadAsstElim) where + +import Data.Maybe +import qualified Data.Set as S + +import Compiler.Hoopl +import Analysis.IR +import Analysis.OptSupport +import Statement (Expression(VariableName)) +-- import Context (VarContext(..), varsNames) + +type Var = String + +type Live = S.Set Var +liveLattice :: DataflowLattice Live +liveLattice = DataflowLattice + { fact_name = "Live variables" + , fact_bot = S.empty + , fact_join = add + } + where add _ (OldFact old) (NewFact new) = (ch, j) + where + j = new `S.union` old + ch = changeIf (S.size j > S.size old) + +liveness :: BwdTransfer Instruction Live +liveness = mkBTransfer live + where + live :: Instruction e x -> Fact x Live -> Live + live (Label _) f = f + live n@(Let x _) f = addUses (S.delete x f) n + live n@(Read x) f = addUses (S.delete x f) n + live n@(Write _) f = addUses f n + live n@(Goto l) f = addUses (fact f l) n + live n@(If _ tl fl) f = addUses (fact f tl `S.union` fact f fl) n + live n@(Call _ _ l) f = addUses (fact f l) n + live n@(Return _) _ = addUses (fact_bot liveLattice) n + live Skip f = f + live n@(While _ l1 l2) f = addUses (fact f l1 `S.union` fact f l2) n + + fact :: FactBase (S.Set Var) -> Label -> Live + fact f l = fromMaybe S.empty $ lookupFact l f + + addUses :: S.Set Var -> Instruction e x -> Live + addUses = fold_EN (fold_EE addVar) + + addVar s (VariableName v) = S.insert v s + addVar s _ = s + +deadAsstElim :: forall m . FuelMonad m => BwdRewrite m Instruction Live +deadAsstElim = mkBRewrite d + where + d :: Instruction e x -> Fact x Live -> m (Maybe (Graph Instruction e x)) + d (Let x _) live + | not (x `S.member` live) = return $ Just emptyGraph + d _ _ = return Nothing diff --git a/src/Analysis/OptSupport.hs b/src/Analysis/OptSupport.hs index 4fa1a04..62f2a7d 100644 --- a/src/Analysis/OptSupport.hs +++ b/src/Analysis/OptSupport.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use camelCase" #-} +{-# LANGUAGE GADTs #-} module Analysis.OptSupport where import Statement @@ -8,20 +9,21 @@ import Analysis.IR fold_EE :: (a -> Expression -> a) -> a -> Expression -> a fold_EN :: (a -> Expression -> a) -> a -> Instruction e x -> a -fold_EE f z e@(Const _) = f z e -fold_EE f z e@(VariableName _) = f z e +fold_EE f z e@(Const _) = f z e +fold_EE f z e@(VariableName _) = f z e fold_EE f z e@(FunctionCall _ exprs) = f (foldl f z exprs) e fold_EE f z e@(Application _ e1 e2) = let afterE1 = fold_EE f z e1 afterE2 = fold_EE f afterE1 e2 in f afterE2 e - -fold_EN _ z (Label _) = z -fold_EN f z (Let _ e) = f z e -fold_EN f z (If e _ _) = f z e -fold_EN f z (Return es) = maybe z (f z) es -fold_EN _ z (Goto _) = z -fold_EN f z (Write e) = f z e -fold_EN f z (Read e) = z -fold_EN _ z (Skip _) = z -fold_EN f z (Call _ _ es _) = foldl f z es \ No newline at end of file + +fold_EN _ z (Label _) = z +fold_EN f z (Analysis.IR.Let _ e) = f z e +fold_EN f z (Analysis.IR.If e _ _) = f z e +fold_EN f z (Return es) = maybe z (f z) es +fold_EN _ z (Goto _) = z +fold_EN f z (Analysis.IR.Write e) = f z e +fold_EN _ z (Analysis.IR.Read _) = z +fold_EN _ z Analysis.IR.Skip = z +fold_EN f z (Call _ es _) = foldl f z es +fold_EN f z (Analysis.IR.While e _ _) = f z e \ No newline at end of file From 6f29081475d4393b4d67876955c18fe1117f470b Mon Sep 17 00:00:00 2001 From: veron Date: Thu, 29 Dec 2022 22:54:29 +0200 Subject: [PATCH 56/75] tests in progress --- L-static-analyzer.cabal | 2 ++ src/Analysis/Live.hs | 5 ++-- src/Execute.hs | 2 +- test/Test/Live.hs | 54 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 59 insertions(+), 4 deletions(-) create mode 100644 test/Test/Live.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 631db09..42aebae 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -27,6 +27,8 @@ library exposed-modules: Analysis.AstToIr Analysis.IR + Analysis.Live + Analysis.OptSupport Console ConsoleParser Context diff --git a/src/Analysis/Live.hs b/src/Analysis/Live.hs index 6f9cb12..e6c8ffc 100644 --- a/src/Analysis/Live.hs +++ b/src/Analysis/Live.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} {-# LANGUAGE ScopedTypeVariables, GADTs #-} -module Analysis.Live (liveLattice, liveness, deadAsstElim) where +module Analysis.Live where import Data.Maybe import qualified Data.Set as S @@ -9,11 +9,10 @@ import Compiler.Hoopl import Analysis.IR import Analysis.OptSupport import Statement (Expression(VariableName)) --- import Context (VarContext(..), varsNames) type Var = String - type Live = S.Set Var + liveLattice :: DataflowLattice Live liveLattice = DataflowLattice { fact_name = "Live variables" diff --git a/src/Execute.hs b/src/Execute.hs index e80f833..cbc2ec8 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -5,7 +5,7 @@ import Control.Monad.State import Error (RuntimeError (..)) import Evaluate (evaluateStatements, evaluateExpression) import Grammar (parseStatement, REPLInput (..), parseStatementOrExpression) -import Data.Maybe (isNothing, isJust, fromJust) +import Data.Maybe (isNothing) import Control.Monad.Trans.Maybe (MaybeT(..)) run :: [String] -> StateT Context IO () diff --git a/test/Test/Live.hs b/test/Test/Live.hs new file mode 100644 index 0000000..73d0fd0 --- /dev/null +++ b/test/Test/Live.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Test.Live where + +import Compiler.Hoopl +import Analysis.IR (Proc (..), M) +import Statement (Statement) +import Grammar (parseStatement) +import Data.Either (isLeft, fromRight) +import Analysis.AstToIr (astToIR) +import Analysis.Live (liveLattice, liveness, deadAsstElim) + +import Test.Tasty.HUnit (assertBool) + +type ErrorM = Either String + +optTest' :: M [Proc] -> ErrorM (M [Proc]) +optTest' procs = + return $ procs >>= mapM optProc + where + optProc proc@Proc {entry, body, args} = do + (body', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body mapEmpty + return $ proc { body = body' } + bwd = BwdPass { bp_lattice = liveLattice + , bp_transfer = liveness + , bp_rewrite = deadAsstElim + } + +parse :: String -> Maybe [Statement] +parse str = if any isLeft parsed + then Nothing + else Just $ foldl f [] parsed + where + parse' ls = map parseStatement ls + parsed = parse' $ lines str + -- f :: [Statement] -> Either (ParseErrorBundle String Void) [Statement] -> [Statement] + f b a = b ++ fromRight [] a + +optimize :: String -> String +optimize text = do + case fmap astToIR (parse text) of + Nothing -> error "Parsing error" + Just ir -> case optTest' (fmap snd ir) of + Left err -> error err + Right p -> do + let opted = runSimpleUniqueMonad $ runWithFuel fuel p + -- lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) p) + -- expected = runSimpleUniqueMonad $ runWithFuel fuel exps + -- TODO: get Instructions from [Proc] + -- foldl (++) [] (map show opted) + where + fuel = 9999 + +unit_Liveness = do + -- putStrLn $ optimize "def f() { x := 1; y := 5; y := x }" \ No newline at end of file From 4ce91fef4bb14db802a461111b5c20df61fa1797 Mon Sep 17 00:00:00 2001 From: khbminus Date: Thu, 29 Dec 2022 23:22:35 +0100 Subject: [PATCH 57/75] IrToAst is ready --- src/Analysis/AstToIr.hs | 16 +++--- src/Analysis/IR.hs | 8 ++- src/Analysis/IrToAst.hs | 121 ++++++++++++++++++++++++++++++++++++++++ src/Statement.hs | 2 +- 4 files changed, 135 insertions(+), 12 deletions(-) create mode 100644 src/Analysis/IrToAst.hs diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index 3ba374f..aecebb3 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -16,23 +16,23 @@ astToIR code = run $ do mapM getFunction (filter isFunctionDeclaration code) getFunction :: A.Statement -> LabelMapM I.Proc -getFunction (A.FunctionDeclaration name (A.Function args body _)) = do - (entry, body') <- toBody body +getFunction (A.FunctionDeclaration name (A.Function args body retExpr)) = do + (entry, body') <- toBody body retExpr putLabel name entry return $ I.Proc {I.name = name, I.args = args, I.body = body', I.entry = entry} getFunction _ = error "only function declaration are supported" -toBody :: [A.Statement] -> LabelMapM (Label, Graph I.Instruction C C) -toBody body = do +toBody :: [A.Statement] -> Maybe A.Expression -> LabelMapM (Label, Graph I.Instruction C C) +toBody body retExpr = do let blocks = splitIntoBlocks body - (lastLabel, lastGraph) <- lastBlock + (lastLabel, lastGraph) <- lastBlock retExpr (fullLabel, fullGraph) <- fullBlockTransform blocks lastLabel return (fullLabel, fullGraph |*><*| lastGraph) -lastBlock :: LabelMapM (Label, Graph I.Instruction C C) -lastBlock = do +lastBlock :: Maybe A.Expression -> LabelMapM (Label, Graph I.Instruction C C) +lastBlock retExpr = do label <- newLabel - return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return Nothing)) + return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return retExpr)) splitIntoBlocks :: [A.Statement] -> [([A.Statement], Maybe A.Statement)] splitIntoBlocks xs = splitHelper xs [] [] diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index 4681462..e3ff840 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -12,12 +12,12 @@ data Proc = Proc { name :: String, args :: [String], entry :: Label, body :: Gra data Instruction e x where Label :: Label -> Instruction C O Let :: String -> Expression -> Instruction O O - If :: Expression -> Label -> Label -> Instruction O C - Return :: Maybe Expression -> Instruction O C - Goto :: Label -> Instruction O C Write :: Expression -> Instruction O O Read :: String -> Instruction O O Skip :: Instruction O O + If :: Expression -> Label -> Label -> Instruction O C + Return :: Maybe Expression -> Instruction O C + Goto :: Label -> Instruction O C While :: Expression -> Label -> Label -> Instruction O C Call :: String -> [Expression] -> Label -> Instruction O C -- accidentally should be OC @@ -25,6 +25,7 @@ instance NonLocal Instruction where entryLabel :: Instruction C x -> Label entryLabel (Label l) = l + successors :: Instruction e C -> [Label] successors (Goto l) = [l] successors (If _ t f) = [t, f] successors (Call _ _ l) = [l] @@ -32,6 +33,7 @@ instance NonLocal Instruction where successors (While _ start next) = [start, next] instance Show (Instruction e x) where + show :: Instruction e x -> String show (Label l) = show l ++ ": " show (Let x expr) = indent $ show x ++ " := " ++ show expr show (If e t f) = indent $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f diff --git a/src/Analysis/IrToAst.hs b/src/Analysis/IrToAst.hs new file mode 100644 index 0000000..a947290 --- /dev/null +++ b/src/Analysis/IrToAst.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE GADTs,TypeFamilies #-} +module Analysis.IrToAst(procToFunc, irToAst, fromProcToBlocks) where + +import qualified Statement as A +import qualified Analysis.IR as I +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Compiler.Hoopl +import Control.Monad.State +import Data.Maybe ( fromMaybe ) + + +-- intermediate data class to represent part in transformation +-- 1) Convert Graph to named blocks of middles and refs to next blocks +-- 2) Recursively +data IRBlock = IRBlock {label :: Label, body :: [A.Statement], next :: I.Instruction O C} deriving (Show) +data IRProc = IRProc {procName :: String, args :: [String], procBody :: [IRBlock]} deriving (Show) + +-- ******** BLOCKS GENERATION ******** + +fromIrInstCO :: I.Instruction C O -> () -> (Label, [A.Statement]) +fromIrInstCO inst _ = case inst of + I.Label l -> (l, []) + +fromIrInstOO :: I.Instruction O O -> (Label, [A.Statement]) -> (Label, [A.Statement]) +fromIrInstOO inst acc = case inst of + I.Let v e -> getNext (A.Let v e) acc + I.Read v -> getNext (A.Read v) acc + I.Write e -> getNext (A.Write e) acc + I.Skip -> getNext A.Skip acc + where + getNext :: A.Statement -> (Label, [A.Statement]) -> (Label, [A.Statement]) + getNext stmt (label, accInstructions) = (label, stmt : accInstructions) + +fromIrInstOC :: I.Instruction O C -> (Label, [A.Statement]) -> IRBlock +fromIrInstOC inst (label, body) = IRBlock {label = label, body = reverse body, next = inst} + +type instance IndexedCO C () (String, [A.Statement]) = () +type instance IndexedCO C IRBlock (String, [A.Statement]) = IRBlock + +fromBlock :: Block I.Instruction C C -> () -> IRBlock +fromBlock = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) + +fromGraph :: Label -> Graph I.Instruction C C -> [IRBlock] +fromGraph entry g = let entryNode = gUnitOC (BlockOC BNil (I.Goto entry)) + blks = reverse $ postorder_dfs (gSplice entryNode g) + in foldl helper [] blks + where + helper :: [IRBlock] -> Block I.Instruction C C -> [IRBlock] + helper p blk = (fromBlock blk () : p) + +fromProcToBlocks :: I.Proc -> IRProc +fromProcToBlocks I.Proc {I.name = n, I.args = a, I.body = body, I.entry = ent} = IRProc {procName = n, procBody = fromGraph ent body, args = a} + +-- ******** BLOCK MERGING ******** + +data IRBlockStorage = IRBlockStorage {blocks :: M.Map Label IRBlock, ast :: M.Map Label [A.Statement], returns :: M.Map Label (Maybe A.Expression)} + +getSuffix :: S.Set Label -> Label -> State IRBlockStorage [A.Statement] +getSuffix whileHeads lbl = do + storage <- get + case M.lookup lbl (ast storage) of + Just stms -> return stms + Nothing -> do + if S.member lbl whileHeads then return [] + else case M.lookup lbl (blocks storage) of + Just block -> transformBlock block whileHeads + Nothing -> error $ "Can't find block with label " ++ show lbl + +transformLast :: Label -> I.Instruction O C -> S.Set Label -> State IRBlockStorage [A.Statement] +transformLast lbl inst whileHeads = do + case inst of + I.Call name args next -> fmap (A.FunctionCallStatement name args:) (getSuffix whileHeads next) + I.Goto next -> getSuffix whileHeads next + I.If e t f -> do + tCode <- getSuffix whileHeads t + fCode <- getSuffix whileHeads f + return [A.If e tCode fCode] + I.While e start next -> do + whileBody <- getSuffix (S.insert lbl whileHeads) start + suffix <- getSuffix whileHeads next + return $ A.While e whileBody : suffix + I.Return x -> do + mp <- get + let rts = returns mp + if M.member lbl rts then error $ "Too many returns for label " ++ show lbl + else do + put $ mp {returns = M.insert lbl x rts} + return [] + + + +transformBlock :: IRBlock -> S.Set Label -> State IRBlockStorage [A.Statement] +transformBlock blk whileHeads = do + if S.member (label blk) whileHeads then return [] + else do + suffixBody <- transformLast (label blk) (next blk) whileHeads + let body' = body blk ++ suffixBody + mp <- get + if not $ M.member (label blk) (ast mp) then do + put $ mp {ast = M.insert (label blk) body' (ast mp)} + return body' + else do + return body' + +procToFunc :: I.Proc -> A.Statement +procToFunc p = let irProc = fromProcToBlocks p in + let blocks' = map (\x -> (label x, x)) (procBody irProc) in + let storage = IRBlockStorage {blocks = M.fromList blocks', ast = M.empty, returns = M.empty } in + let (body', storage') = runState (transformBlock (get' storage) S.empty) storage in + A.FunctionDeclaration (procName irProc) (A.Function (args irProc) body' (getReturn storage')) + where + get' :: IRBlockStorage -> IRBlock + get' s = case M.lookup (I.entry p) (blocks s) of + Just x -> x + Nothing -> error $ "can't find start block with label " ++ show (I.entry p) + getReturn :: IRBlockStorage -> Maybe A.Expression + getReturn s = fromMaybe Nothing (M.lookup (I.entry p) (returns s)) + +irToAst :: [I.Proc] -> [A.Statement] +irToAst = map procToFunc \ No newline at end of file diff --git a/src/Statement.hs b/src/Statement.hs index 10b3c78..9a733a1 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -73,7 +73,7 @@ data Function = Function [String] [Statement] (Maybe Expression) deriving (Eq) instance Show Function where show (Function args body Nothing) = "(" ++ show args ++ ") {" ++ show body ++ "}" - show (Function args body (Just ret)) = "(" ++ show args ++ ") {" ++ show body ++ "} return" ++ show ret + show (Function args body (Just ret)) = "(" ++ show args ++ ") {" ++ show body ++ "} return " ++ show ret reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file From aa041ea43aa27f727286af95e2365f9401fd07d5 Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 30 Dec 2022 10:24:18 +0200 Subject: [PATCH 58/75] fixme: function returns are lost after IR --- L-static-analyzer.cabal | 2 + src/Analysis/AstToIr.hs | 18 +++--- src/Analysis/IR.hs | 8 ++- src/Analysis/IrToAst.hs | 121 ++++++++++++++++++++++++++++++++++++++++ src/Statement.hs | 9 ++- test/Test/Live.hs | 14 ++++- 6 files changed, 155 insertions(+), 17 deletions(-) create mode 100644 src/Analysis/IrToAst.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 42aebae..0d27e73 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -26,6 +26,7 @@ source-repository head library exposed-modules: Analysis.AstToIr + Analysis.IrToAst Analysis.IR Analysis.Live Analysis.OptSupport @@ -82,6 +83,7 @@ test-suite L-static-analyzer-test Test.Evaluate Test.Execute Test.Parsers + Test.Live Paths_L_static_analyzer hs-source-dirs: test diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index 7c69f88..aecebb3 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -16,23 +16,23 @@ astToIR code = run $ do mapM getFunction (filter isFunctionDeclaration code) getFunction :: A.Statement -> LabelMapM I.Proc -getFunction (A.FunctionDeclaration name (A.Function args body _)) = do - (entry, body') <- toBody body +getFunction (A.FunctionDeclaration name (A.Function args body retExpr)) = do + (entry, body') <- toBody body retExpr putLabel name entry return $ I.Proc {I.name = name, I.args = args, I.body = body', I.entry = entry} getFunction _ = error "only function declaration are supported" -toBody :: [A.Statement] -> LabelMapM (Label, Graph I.Instruction C C) -toBody body = do +toBody :: [A.Statement] -> Maybe A.Expression -> LabelMapM (Label, Graph I.Instruction C C) +toBody body retExpr = do let blocks = splitIntoBlocks body - (lastLabel, lastGraph) <- lastBlock + (lastLabel, lastGraph) <- lastBlock retExpr (fullLabel, fullGraph) <- fullBlockTransform blocks lastLabel return (fullLabel, fullGraph |*><*| lastGraph) -lastBlock :: LabelMapM (Label, Graph I.Instruction C C) -lastBlock = do +lastBlock :: Maybe A.Expression -> LabelMapM (Label, Graph I.Instruction C C) +lastBlock retExpr = do label <- newLabel - return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return Nothing)) + return (label, mkFirst (I.Label label) H.<*> mkMiddles [] H.<*> mkLast (I.Return retExpr)) splitIntoBlocks :: [A.Statement] -> [([A.Statement], Maybe A.Statement)] splitIntoBlocks xs = splitHelper xs [] [] @@ -73,7 +73,7 @@ toLast (Just (A.While e s)) next = do let blocks = splitIntoBlocks s whileLabel <- newLabel (sLabel, sGraph) <- fullBlockTransform blocks whileLabel - let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.If e sLabel next) + let whileGraph = mkFirst (I.Label whileLabel) H.<*> mkMiddles [] H.<*> mkLast (I.While e sLabel next) return (I.Goto whileLabel, whileGraph |*><*| sGraph) toLast (Just (A.FunctionCallStatement name args)) next = return (I.Call name args next, emptyClosedGraph) toLast _ _ = error "invalid last" diff --git a/src/Analysis/IR.hs b/src/Analysis/IR.hs index 4681462..e3ff840 100644 --- a/src/Analysis/IR.hs +++ b/src/Analysis/IR.hs @@ -12,12 +12,12 @@ data Proc = Proc { name :: String, args :: [String], entry :: Label, body :: Gra data Instruction e x where Label :: Label -> Instruction C O Let :: String -> Expression -> Instruction O O - If :: Expression -> Label -> Label -> Instruction O C - Return :: Maybe Expression -> Instruction O C - Goto :: Label -> Instruction O C Write :: Expression -> Instruction O O Read :: String -> Instruction O O Skip :: Instruction O O + If :: Expression -> Label -> Label -> Instruction O C + Return :: Maybe Expression -> Instruction O C + Goto :: Label -> Instruction O C While :: Expression -> Label -> Label -> Instruction O C Call :: String -> [Expression] -> Label -> Instruction O C -- accidentally should be OC @@ -25,6 +25,7 @@ instance NonLocal Instruction where entryLabel :: Instruction C x -> Label entryLabel (Label l) = l + successors :: Instruction e C -> [Label] successors (Goto l) = [l] successors (If _ t f) = [t, f] successors (Call _ _ l) = [l] @@ -32,6 +33,7 @@ instance NonLocal Instruction where successors (While _ start next) = [start, next] instance Show (Instruction e x) where + show :: Instruction e x -> String show (Label l) = show l ++ ": " show (Let x expr) = indent $ show x ++ " := " ++ show expr show (If e t f) = indent $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f diff --git a/src/Analysis/IrToAst.hs b/src/Analysis/IrToAst.hs new file mode 100644 index 0000000..a947290 --- /dev/null +++ b/src/Analysis/IrToAst.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE GADTs,TypeFamilies #-} +module Analysis.IrToAst(procToFunc, irToAst, fromProcToBlocks) where + +import qualified Statement as A +import qualified Analysis.IR as I +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Compiler.Hoopl +import Control.Monad.State +import Data.Maybe ( fromMaybe ) + + +-- intermediate data class to represent part in transformation +-- 1) Convert Graph to named blocks of middles and refs to next blocks +-- 2) Recursively +data IRBlock = IRBlock {label :: Label, body :: [A.Statement], next :: I.Instruction O C} deriving (Show) +data IRProc = IRProc {procName :: String, args :: [String], procBody :: [IRBlock]} deriving (Show) + +-- ******** BLOCKS GENERATION ******** + +fromIrInstCO :: I.Instruction C O -> () -> (Label, [A.Statement]) +fromIrInstCO inst _ = case inst of + I.Label l -> (l, []) + +fromIrInstOO :: I.Instruction O O -> (Label, [A.Statement]) -> (Label, [A.Statement]) +fromIrInstOO inst acc = case inst of + I.Let v e -> getNext (A.Let v e) acc + I.Read v -> getNext (A.Read v) acc + I.Write e -> getNext (A.Write e) acc + I.Skip -> getNext A.Skip acc + where + getNext :: A.Statement -> (Label, [A.Statement]) -> (Label, [A.Statement]) + getNext stmt (label, accInstructions) = (label, stmt : accInstructions) + +fromIrInstOC :: I.Instruction O C -> (Label, [A.Statement]) -> IRBlock +fromIrInstOC inst (label, body) = IRBlock {label = label, body = reverse body, next = inst} + +type instance IndexedCO C () (String, [A.Statement]) = () +type instance IndexedCO C IRBlock (String, [A.Statement]) = IRBlock + +fromBlock :: Block I.Instruction C C -> () -> IRBlock +fromBlock = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) + +fromGraph :: Label -> Graph I.Instruction C C -> [IRBlock] +fromGraph entry g = let entryNode = gUnitOC (BlockOC BNil (I.Goto entry)) + blks = reverse $ postorder_dfs (gSplice entryNode g) + in foldl helper [] blks + where + helper :: [IRBlock] -> Block I.Instruction C C -> [IRBlock] + helper p blk = (fromBlock blk () : p) + +fromProcToBlocks :: I.Proc -> IRProc +fromProcToBlocks I.Proc {I.name = n, I.args = a, I.body = body, I.entry = ent} = IRProc {procName = n, procBody = fromGraph ent body, args = a} + +-- ******** BLOCK MERGING ******** + +data IRBlockStorage = IRBlockStorage {blocks :: M.Map Label IRBlock, ast :: M.Map Label [A.Statement], returns :: M.Map Label (Maybe A.Expression)} + +getSuffix :: S.Set Label -> Label -> State IRBlockStorage [A.Statement] +getSuffix whileHeads lbl = do + storage <- get + case M.lookup lbl (ast storage) of + Just stms -> return stms + Nothing -> do + if S.member lbl whileHeads then return [] + else case M.lookup lbl (blocks storage) of + Just block -> transformBlock block whileHeads + Nothing -> error $ "Can't find block with label " ++ show lbl + +transformLast :: Label -> I.Instruction O C -> S.Set Label -> State IRBlockStorage [A.Statement] +transformLast lbl inst whileHeads = do + case inst of + I.Call name args next -> fmap (A.FunctionCallStatement name args:) (getSuffix whileHeads next) + I.Goto next -> getSuffix whileHeads next + I.If e t f -> do + tCode <- getSuffix whileHeads t + fCode <- getSuffix whileHeads f + return [A.If e tCode fCode] + I.While e start next -> do + whileBody <- getSuffix (S.insert lbl whileHeads) start + suffix <- getSuffix whileHeads next + return $ A.While e whileBody : suffix + I.Return x -> do + mp <- get + let rts = returns mp + if M.member lbl rts then error $ "Too many returns for label " ++ show lbl + else do + put $ mp {returns = M.insert lbl x rts} + return [] + + + +transformBlock :: IRBlock -> S.Set Label -> State IRBlockStorage [A.Statement] +transformBlock blk whileHeads = do + if S.member (label blk) whileHeads then return [] + else do + suffixBody <- transformLast (label blk) (next blk) whileHeads + let body' = body blk ++ suffixBody + mp <- get + if not $ M.member (label blk) (ast mp) then do + put $ mp {ast = M.insert (label blk) body' (ast mp)} + return body' + else do + return body' + +procToFunc :: I.Proc -> A.Statement +procToFunc p = let irProc = fromProcToBlocks p in + let blocks' = map (\x -> (label x, x)) (procBody irProc) in + let storage = IRBlockStorage {blocks = M.fromList blocks', ast = M.empty, returns = M.empty } in + let (body', storage') = runState (transformBlock (get' storage) S.empty) storage in + A.FunctionDeclaration (procName irProc) (A.Function (args irProc) body' (getReturn storage')) + where + get' :: IRBlockStorage -> IRBlock + get' s = case M.lookup (I.entry p) (blocks s) of + Just x -> x + Nothing -> error $ "can't find start block with label " ++ show (I.entry p) + getReturn :: IRBlockStorage -> Maybe A.Expression + getReturn s = fromMaybe Nothing (M.lookup (I.entry p) (returns s)) + +irToAst :: [I.Proc] -> [A.Statement] +irToAst = map procToFunc \ No newline at end of file diff --git a/src/Statement.hs b/src/Statement.hs index 10b3c78..647ed1c 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -71,9 +71,14 @@ instance Show Statement where data Function = Function [String] [Statement] (Maybe Expression) deriving (Eq) +joinToString :: Show a => String -> [a] -> String +joinToString _ [x] = show x +joinToString delim (x:xs) = show x ++ delim ++ joinToString delim xs +joinToString _ [] = "" + instance Show Function where - show (Function args body Nothing) = "(" ++ show args ++ ") {" ++ show body ++ "}" - show (Function args body (Just ret)) = "(" ++ show args ++ ") {" ++ show body ++ "} return" ++ show ret + show (Function args body Nothing) = "(" ++ joinToString ", " args ++ ") { " ++ joinToString "; " body ++ " }" + show (Function args body (Just ret)) = "(" ++ joinToString ", " args ++ ") { " ++ joinToString "; " body ++ " } return " ++ show ret reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/test/Test/Live.hs b/test/Test/Live.hs index 73d0fd0..f86a255 100644 --- a/test/Test/Live.hs +++ b/test/Test/Live.hs @@ -6,7 +6,9 @@ import Analysis.IR (Proc (..), M) import Statement (Statement) import Grammar (parseStatement) import Data.Either (isLeft, fromRight) +import Data.Maybe (fromJust) import Analysis.AstToIr (astToIR) +import Analysis.IrToAst (irToAst) import Analysis.Live (liveLattice, liveness, deadAsstElim) import Test.Tasty.HUnit (assertBool) @@ -35,7 +37,7 @@ parse str = if any isLeft parsed -- f :: [Statement] -> Either (ParseErrorBundle String Void) [Statement] -> [Statement] f b a = b ++ fromRight [] a -optimize :: String -> String +optimize :: String -> [Statement] optimize text = do case fmap astToIR (parse text) of Nothing -> error "Parsing error" @@ -46,9 +48,15 @@ optimize text = do -- lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) p) -- expected = runSimpleUniqueMonad $ runWithFuel fuel exps -- TODO: get Instructions from [Proc] - -- foldl (++) [] (map show opted) + irToAst opted where fuel = 9999 +unit_Liveness :: IO () unit_Liveness = do - -- putStrLn $ optimize "def f() { x := 1; y := 5; y := x }" \ No newline at end of file + let testCode = "def f() { skip } return 5" + print testCode + let parsed = fromJust (parse testCode) + let ir = fmap snd (astToIR parsed) + let opted = runSimpleUniqueMonad $ runWithFuel 9999 ir + print $ (show . head) $ irToAst opted \ No newline at end of file From 6c6b90aad1c16147d795f6f4bd31f1362ea3cd21 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 09:40:21 +0100 Subject: [PATCH 59/75] fixed return in irToAst --- src/Analysis/IrToAst.hs | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/src/Analysis/IrToAst.hs b/src/Analysis/IrToAst.hs index a947290..6791635 100644 --- a/src/Analysis/IrToAst.hs +++ b/src/Analysis/IrToAst.hs @@ -103,6 +103,23 @@ transformBlock blk whileHeads = do else do return body' +findReturn :: Label -> S.Set Label -> State IRBlockStorage (Maybe (Maybe A.Expression)) +findReturn blk used = do + storage <- get + case M.lookup blk (blocks storage) of + Nothing -> return Nothing + Just blk' -> + case next blk' of + I.Return x -> return $ Just x + I.Goto l -> go l + I.Call _ _ l -> go l + I.If _ t _ -> go t -- only one return is possible, moreover return is placed in end of each branch of if + I.While _ _ l -> go l + where + go :: Label -> State IRBlockStorage (Maybe (Maybe A.Expression)) + go l = if S.member l used then return Nothing else findReturn l (S.insert l used) + + procToFunc :: I.Proc -> A.Statement procToFunc p = let irProc = fromProcToBlocks p in let blocks' = map (\x -> (label x, x)) (procBody irProc) in @@ -115,7 +132,7 @@ procToFunc p = let irProc = fromProcToBlocks p in Just x -> x Nothing -> error $ "can't find start block with label " ++ show (I.entry p) getReturn :: IRBlockStorage -> Maybe A.Expression - getReturn s = fromMaybe Nothing (M.lookup (I.entry p) (returns s)) + getReturn s = fromMaybe Nothing $ evalState (findReturn (I.entry p) S.empty) s irToAst :: [I.Proc] -> [A.Statement] irToAst = map procToFunc \ No newline at end of file From 6c45b06bc5436cfeb2172dcd2e7f0ffb6a0f7dfe Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 30 Dec 2022 12:23:58 +0200 Subject: [PATCH 60/75] simple tests --- src/Analysis/IrToAst.hs | 19 ++++++++++++- src/Statement.hs | 9 +++++-- test/Test/Live.hs | 59 +++++++++++++++++++++++++++++++---------- 3 files changed, 70 insertions(+), 17 deletions(-) diff --git a/src/Analysis/IrToAst.hs b/src/Analysis/IrToAst.hs index a947290..6791635 100644 --- a/src/Analysis/IrToAst.hs +++ b/src/Analysis/IrToAst.hs @@ -103,6 +103,23 @@ transformBlock blk whileHeads = do else do return body' +findReturn :: Label -> S.Set Label -> State IRBlockStorage (Maybe (Maybe A.Expression)) +findReturn blk used = do + storage <- get + case M.lookup blk (blocks storage) of + Nothing -> return Nothing + Just blk' -> + case next blk' of + I.Return x -> return $ Just x + I.Goto l -> go l + I.Call _ _ l -> go l + I.If _ t _ -> go t -- only one return is possible, moreover return is placed in end of each branch of if + I.While _ _ l -> go l + where + go :: Label -> State IRBlockStorage (Maybe (Maybe A.Expression)) + go l = if S.member l used then return Nothing else findReturn l (S.insert l used) + + procToFunc :: I.Proc -> A.Statement procToFunc p = let irProc = fromProcToBlocks p in let blocks' = map (\x -> (label x, x)) (procBody irProc) in @@ -115,7 +132,7 @@ procToFunc p = let irProc = fromProcToBlocks p in Just x -> x Nothing -> error $ "can't find start block with label " ++ show (I.entry p) getReturn :: IRBlockStorage -> Maybe A.Expression - getReturn s = fromMaybe Nothing (M.lookup (I.entry p) (returns s)) + getReturn s = fromMaybe Nothing $ evalState (findReturn (I.entry p) S.empty) s irToAst :: [I.Proc] -> [A.Statement] irToAst = map procToFunc \ No newline at end of file diff --git a/src/Statement.hs b/src/Statement.hs index 647ed1c..9783cb2 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -76,9 +76,14 @@ joinToString _ [x] = show x joinToString delim (x:xs) = show x ++ delim ++ joinToString delim xs joinToString _ [] = "" +bodyToString :: [Statement] -> String +bodyToString body = case body of + [] -> "skip" + b -> joinToString "; " b + instance Show Function where - show (Function args body Nothing) = "(" ++ joinToString ", " args ++ ") { " ++ joinToString "; " body ++ " }" - show (Function args body (Just ret)) = "(" ++ joinToString ", " args ++ ") { " ++ joinToString "; " body ++ " } return " ++ show ret + show (Function args body Nothing) = "(" ++ joinToString ", " args ++ ") { " ++ bodyToString body ++ " }" + show (Function args body (Just ret)) = "(" ++ joinToString ", " args ++ ") { " ++ bodyToString body ++ " } return " ++ show ret reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/test/Test/Live.hs b/test/Test/Live.hs index f86a255..0ccae64 100644 --- a/test/Test/Live.hs +++ b/test/Test/Live.hs @@ -2,21 +2,21 @@ module Test.Live where import Compiler.Hoopl -import Analysis.IR (Proc (..), M) -import Statement (Statement) -import Grammar (parseStatement) +import Analysis.IR (Proc (..), M, Instruction (Return)) +import Statement (Statement (..), Function (Function), Expression (..), Operations (Equals, Addition)) +import Grammar (parseStatement, ifThenElse) import Data.Either (isLeft, fromRight) import Data.Maybe (fromJust) import Analysis.AstToIr (astToIR) import Analysis.IrToAst (irToAst) import Analysis.Live (liveLattice, liveness, deadAsstElim) -import Test.Tasty.HUnit (assertBool) +import Test.Tasty.HUnit (assertBool, assertEqual) type ErrorM = Either String -optTest' :: M [Proc] -> ErrorM (M [Proc]) -optTest' procs = +liveOpt :: M [Proc] -> ErrorM (M [Proc]) +liveOpt procs = return $ procs >>= mapM optProc where optProc proc@Proc {entry, body, args} = do @@ -34,14 +34,13 @@ parse str = if any isLeft parsed where parse' ls = map parseStatement ls parsed = parse' $ lines str - -- f :: [Statement] -> Either (ParseErrorBundle String Void) [Statement] -> [Statement] f b a = b ++ fromRight [] a optimize :: String -> [Statement] optimize text = do case fmap astToIR (parse text) of Nothing -> error "Parsing error" - Just ir -> case optTest' (fmap snd ir) of + Just ir -> case liveOpt (fmap snd ir) of Left err -> error err Right p -> do let opted = runSimpleUniqueMonad $ runWithFuel fuel p @@ -54,9 +53,41 @@ optimize text = do unit_Liveness :: IO () unit_Liveness = do - let testCode = "def f() { skip } return 5" - print testCode - let parsed = fromJust (parse testCode) - let ir = fmap snd (astToIR parsed) - let opted = runSimpleUniqueMonad $ runWithFuel 9999 ir - print $ (show . head) $ irToAst opted \ No newline at end of file + let testCode1 = "def f() { x := 5; y := x } return 1" + let expected1 = [FunctionDeclaration "f" (Function [] [] (Just $ Const 1))] + + let testCode2 = "def f() { x := 5; y := 1 } return x" + let expected2 = [FunctionDeclaration "f" (Function [] [Let "x" (Const 5)] (Just $ VariableName "x"))] + + let testCode3 = "def f() { x := 5; x := 1 } return x" + let expected3 = [FunctionDeclaration "f" (Function [] [Let "x" (Const 1)] (Just $ VariableName "x"))] + + + assertEqual "Liveness 1" (optimize testCode1) expected1 + assertEqual "Liveness 2" (optimize testCode2) expected2 + assertEqual "Liveness 3" (optimize testCode3) expected3 + +unit_ReadWrite :: IO () +unit_ReadWrite = do + let testCode1 = "def f() { read x }" + let expected1 = [FunctionDeclaration "f" (Function [] [Read "x"] Nothing)] + + let testCode2 = "def f() { x := 0; write x }" + let expected2 = [FunctionDeclaration "f" (Function [] [Let "x" $ Const 0, Write $ VariableName "x"] Nothing)] + + assertEqual "Liveness 1" (optimize testCode1) expected1 + assertEqual "Liveness 2" (optimize testCode2) expected2 + +-- unit_If :: IO () +-- unit_If = do +-- let increment var expr = Let var (Application Addition (VariableName var) expr) + +-- let testCode1 = "def f() { y := 0; z := 0; if 0 == 0 then y := y + 3 else z := z + 1 } return y" +-- let expected1 = [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), If (Application Equals (Const 0) (Const 0)) [increment "y" (Const 3)] []] (Just $ VariableName "y"))] + +-- let testCode2 = "def f() { y := 0; z := 0; if x == 0 then y := y + 3 else z := z + 1 } return y + z" +-- let expected2 = fromJust $ parse testCode2 +-- -- [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), Let "z" (Const 0), If (Application Equals (Const 0) (Const 0)) [increment "y" (Const 3)] [increment "z" (Const 1)]] (Just $ Application Addition (VariableName "y") (VariableName "z")))] + +-- assertEqual "remove branch" (optimize testCode1) expected1 +-- assertEqual "unchanged" (optimize testCode2) expected2 From fd9c8a61d1115a30155df062072baa41b491f498 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 11:30:39 +0100 Subject: [PATCH 61/75] Added more brackets for consistency --- src/Grammar.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index 4cb0949..709238d 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -47,6 +47,9 @@ funCall = do parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") +curlyParens :: Parser a -> Parser a +curlyParens = between (symbol "{") (symbol "}") + expressionTerm :: Parser Expression expressionTerm = choice @@ -104,7 +107,7 @@ while = singleton <$> ( While <$> (between (symbol "while") (symbol "do") expression "While condition") - <*> (statement "While statement") + <*> (curlyParens statement "While statement") ) ifThenElse :: Parser [Statement] @@ -112,8 +115,8 @@ ifThenElse = singleton <$> ( If <$> (symbol "if" *> expression "If condition") - <*> (symbol "then" *> statement "True statement") - <*> (symbol "else" *> statement "False Statement") + <*> (symbol "then" *> curlyParens statement "True statement") + <*> (symbol "else" *> curlyParens statement "False Statement") ) funCallStatement :: Parser [Statement] @@ -132,8 +135,8 @@ functionDeclaration = buildDeclaration <$> (symbol "def" *> name) <*> parens (name `sepBy` symbol ",") - <*> (symbol "{" *> statement) - <*> (symbol "}" *> optional (symbol "return" *> expression)) + <*> curlyParens statement + <*> optional (symbol "return" *> expression) where buildDeclaration a b c d = [FunctionDeclaration a (Function b c d)] @@ -144,14 +147,13 @@ split :: Parser [Statement] split = concat <$> (statement `sepBy1` symbol ";") statement :: Parser [Statement] -statement = - try while - <|> try ifThenElse - <|> concat <$> (terms `sepBy1` symbol ";") +statement = concat <$> (terms `sepBy1` symbol ";") where terms = choice - [ write, + [ ifThenElse, + while, + write, readVariable, skip, try funCallStatement, From 1b60565841820259239ea56d1913599de0aee5ff Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 11:34:47 +0100 Subject: [PATCH 62/75] test fixes --- test/Test/Parsers.hs | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 8b48da5..0013ad2 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -93,7 +93,7 @@ unit_let = do ) ] - assertBool "assign statement" $ fail "x := while 1 do 2" + assertBool "assign statement" $ fail "x := while 1 do { 2 }" assertBool "assign function call" $ success @@ -116,10 +116,10 @@ unit_while = do let success = parseSuccessful while let fail = parseFailed while - assertBool "simple while" $ success "while 1 do x := x" [While (Const 1) [Let "x" (VariableName "x")]] + assertBool "simple while" $ success "while 1 do { x := x }" [While (Const 1) [Let "x" (VariableName "x")]] assertBool "complicated expression" $ success - "while 1 + 2 do x := x" + "while 1 + 2 do { x := x }" [ While (Application $ Addition (Const 1) (Const 2)) [Let "x" (VariableName "x")] @@ -127,7 +127,7 @@ unit_while = do assertBool "function call" $ success - "while f(1) do x := x" + "while f(1) do { x := x }" [ While (FunctionCall "f" [Const 1]) [Let "x" (VariableName "x")] @@ -136,7 +136,7 @@ unit_while = do assertBool "just while fails" $ fail "while" assertBool "just while-do failes" $ fail "while do" assertBool "without statement fail" $ fail "while 1 do" - assertBool "without condition fail" $ fail "while do x := x" + assertBool "without condition fail" $ fail "while do { x := x }" unit_if :: IO () unit_if = do @@ -145,7 +145,7 @@ unit_if = do assertBool "simple if" $ success - "if 1 then a(1) else a(2)" + "if 1 then { a(1) } else { a(2) }" [ If (Const 1) [FunctionCallStatement "a" [Const 1]] @@ -180,7 +180,7 @@ unit_statement = do assertBool "multiplie statements" $ success "x := a; y := b" [Let "x" $ VariableName "a", Let "y" $ VariableName "b"] assertBool "while with long body" $ success - "while 1 do x := a; y := b" + "while 1 do { x := a; y := b }" [ While (Const 1) [ Let "x" $ VariableName "a", @@ -219,5 +219,21 @@ unit_functionsDeclarations = do assertBool "With params" $ success "def f(a, b, c, d, e, f) { skip }" [FunctionDeclaration "f" (Function ["a", "b", "c", "d", "e", "f"] [Skip] Nothing)] assertBool "Identity function" $ success "def f(x) { skip } return x" [FunctionDeclaration "f" (Function ["x"] [Skip] (Just $ VariableName "x"))] - assertBool "Wierd argument name" $ fail "def f(asdas d sda ) {skip}" + assertBool "Weird argument name" $ fail "def f(asdas d sda ) {skip}" assertBool "Unclosed comma" $ fail "def f(a,) {skip}" + + assertBool "If in the middle of declaration" $ success "def f() { x := 0; if 0 == 0 then { y := y + 3 } else { z := z + 1 } } return y" + [FunctionDeclaration "f" ( + Function + [] + [ + Let "x" (Const 0), + If (Application (Equals (Const 0) (Const 0))) + [ + Let "y" (Application (Addition (VariableName "y") (Const 3))) + ] + [ + Let "z" (Application (Addition (VariableName "z") (Const 1))) + ] + ] + (Just (VariableName "y")))] From d66b1d96e36f2c858f893fb2f7f614904a62c65a Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 12:49:28 +0100 Subject: [PATCH 63/75] test fix --- test/Test/Parsers.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 7dc124f..8f701b8 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -228,12 +228,12 @@ unit_functionsDeclarations = do [] [ Let "x" (Const 0), - If (Application (Equals (Const 0) (Const 0))) + If (Application Equals (Const 0) (Const 0)) [ - Let "y" (Application (Addition (VariableName "y") (Const 3))) + Let "y" (Application Addition (VariableName "y") (Const 3)) ] [ - Let "z" (Application (Addition (VariableName "z") (Const 1))) + Let "z" (Application Addition (VariableName "z") (Const 1)) ] ] (Just (VariableName "y")))] From e85fa7a36cb6561cd02762e5d047f10f647dedfb Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 30 Dec 2022 14:13:10 +0200 Subject: [PATCH 64/75] finish tests for liveness --- src/Grammar.hs | 22 ++++++++++++---------- src/Statement.hs | 29 +++++++++++++++-------------- test/Test/Live.hs | 41 +++++++++++++++++++++++++++-------------- test/Test/Parsers.hs | 32 ++++++++++++++++++++++++-------- 4 files changed, 78 insertions(+), 46 deletions(-) diff --git a/src/Grammar.hs b/src/Grammar.hs index 4c68dc5..4c4751e 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -47,6 +47,9 @@ funCall = do parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") +curlyParens :: Parser a -> Parser a +curlyParens = between (symbol "{") (symbol "}") + expressionTerm :: Parser Expression expressionTerm = choice @@ -101,7 +104,7 @@ while = singleton <$> ( While <$> (between (symbol "while") (symbol "do") expression "While condition") - <*> (statement "While statement") + <*> (curlyParens statement "While statement") ) ifThenElse :: Parser [Statement] @@ -109,8 +112,8 @@ ifThenElse = singleton <$> ( If <$> (symbol "if" *> expression "If condition") - <*> (symbol "then" *> statement "True statement") - <*> (symbol "else" *> statement "False Statement") + <*> (symbol "then" *> curlyParens statement "True statement") + <*> (symbol "else" *> curlyParens statement "False Statement") ) funCallStatement :: Parser [Statement] @@ -129,8 +132,8 @@ functionDeclaration = buildDeclaration <$> (symbol "def" *> name) <*> parens (name `sepBy` symbol ",") - <*> (symbol "{" *> statement) - <*> (symbol "}" *> optional (symbol "return" *> expression)) + <*> curlyParens statement + <*> optional (symbol "return" *> expression) where buildDeclaration a b c d = [FunctionDeclaration a (Function b c d)] @@ -141,14 +144,13 @@ split :: Parser [Statement] split = concat <$> (statement `sepBy1` symbol ";") statement :: Parser [Statement] -statement = - try while - <|> try ifThenElse - <|> concat <$> (terms `sepBy1` symbol ";") +statement = concat <$> (terms `sepBy1` symbol ";") where terms = choice - [ write, + [ ifThenElse, + while, + write, readVariable, skip, try funCallStatement, diff --git a/src/Statement.hs b/src/Statement.hs index 9783cb2..ea9233e 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -59,31 +59,32 @@ data Statement | Skip deriving (Eq) +joinToString :: Show a => String -> [a] -> String +joinToString _ [x] = show x +joinToString delim (x:xs) = show x ++ delim ++ joinToString delim xs +joinToString _ [] = "" + +bodyToString :: [Statement] -> String +bodyToString body = "{ " ++ case body of + [] -> "skip" + b -> joinToString "; " b + ++ " }" + instance Show Statement where show (Let x expr) = x ++ " := " ++ show expr show (FunctionCallStatement name args) = name ++ "(" ++ show args ++ ")" show (FunctionDeclaration name f) = "def " ++ name ++ show f show (Write x) = "write " ++ show x show (Read x) = "read " ++ x - show (While e s) = "while (" ++ show e ++ ") {" ++ show s ++ "}" - show (If e t f) = "If " ++ show e ++ " then " ++ show t ++ " else " ++ show f + show (While e s) = "while (" ++ show e ++ ") " ++ bodyToString s + show (If e t f) = "If " ++ show e ++ " then " ++ bodyToString t ++ " else " ++ bodyToString f show Skip = "skip" data Function = Function [String] [Statement] (Maybe Expression) deriving (Eq) -joinToString :: Show a => String -> [a] -> String -joinToString _ [x] = show x -joinToString delim (x:xs) = show x ++ delim ++ joinToString delim xs -joinToString _ [] = "" - -bodyToString :: [Statement] -> String -bodyToString body = case body of - [] -> "skip" - b -> joinToString "; " b - instance Show Function where - show (Function args body Nothing) = "(" ++ joinToString ", " args ++ ") { " ++ bodyToString body ++ " }" - show (Function args body (Just ret)) = "(" ++ joinToString ", " args ++ ") { " ++ bodyToString body ++ " } return " ++ show ret + show (Function args body Nothing) = "(" ++ joinToString ", " args ++ ") " ++ bodyToString body + show (Function args body (Just ret)) = "(" ++ joinToString ", " args ++ ") " ++ bodyToString body ++ " return " ++ show ret reservedKeywords :: [String] reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/test/Test/Live.hs b/test/Test/Live.hs index 0ccae64..efe7dcb 100644 --- a/test/Test/Live.hs +++ b/test/Test/Live.hs @@ -2,16 +2,16 @@ module Test.Live where import Compiler.Hoopl -import Analysis.IR (Proc (..), M, Instruction (Return)) +import Analysis.IR (Proc (..), M) import Statement (Statement (..), Function (Function), Expression (..), Operations (Equals, Addition)) -import Grammar (parseStatement, ifThenElse) +import Grammar (parseStatement) import Data.Either (isLeft, fromRight) import Data.Maybe (fromJust) import Analysis.AstToIr (astToIR) import Analysis.IrToAst (irToAst) import Analysis.Live (liveLattice, liveness, deadAsstElim) -import Test.Tasty.HUnit (assertBool, assertEqual) +import Test.Tasty.HUnit (assertEqual) type ErrorM = Either String @@ -51,6 +51,9 @@ optimize text = do where fuel = 9999 +increment :: String -> Expression -> Statement +increment var expr = Let var (Application Addition (VariableName var) expr) + unit_Liveness :: IO () unit_Liveness = do let testCode1 = "def f() { x := 5; y := x } return 1" @@ -78,16 +81,26 @@ unit_ReadWrite = do assertEqual "Liveness 1" (optimize testCode1) expected1 assertEqual "Liveness 2" (optimize testCode2) expected2 --- unit_If :: IO () --- unit_If = do --- let increment var expr = Let var (Application Addition (VariableName var) expr) - --- let testCode1 = "def f() { y := 0; z := 0; if 0 == 0 then y := y + 3 else z := z + 1 } return y" --- let expected1 = [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), If (Application Equals (Const 0) (Const 0)) [increment "y" (Const 3)] []] (Just $ VariableName "y"))] +unit_If :: IO () +unit_If = do + let testCode1 = "def f() { y := 0; z := 0; if z == 0 then { y := y + 3 } else { z := z + 1 } } return y" + let expected1 = [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), Let "z" (Const 0), If (Application Equals (VariableName "z") (Const 0)) [increment "y" (Const 3)] []] (Just $ VariableName "y"))] --- let testCode2 = "def f() { y := 0; z := 0; if x == 0 then y := y + 3 else z := z + 1 } return y + z" --- let expected2 = fromJust $ parse testCode2 --- -- [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), Let "z" (Const 0), If (Application Equals (Const 0) (Const 0)) [increment "y" (Const 3)] [increment "z" (Const 1)]] (Just $ Application Addition (VariableName "y") (VariableName "z")))] + let testCode2 = "def f() { y := 0; z := 0; if z == 0 then { y := y + 3 } else { z := z + 1 } } return y + z" + let expected2 = fromJust $ parse testCode2 + + assertEqual "remove branch" (optimize testCode1) expected1 + assertEqual "unchanged" (optimize testCode2) expected2 + +unit_While :: IO () +unit_While = do + let testCode1 = "def f() { x := 0; while 0 == 0 do { x := x + 3 } } return x" + let expected1 = fromJust $ parse testCode1 + + let testCode2 = "def f() { x := 0; while 0 == 0 do { x := x + 3 } }" + let expected2 = [FunctionDeclaration "f" $ Function [] [While (Application Equals (Const 0) (Const 0)) []] Nothing] --- assertEqual "remove branch" (optimize testCode1) expected1 --- assertEqual "unchanged" (optimize testCode2) expected2 + print (optimize testCode2) + print expected2 + assertEqual "unchanged" (optimize testCode1) expected1 + assertEqual "remove x" (optimize testCode2) expected2 diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index d24c122..8f701b8 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -93,7 +93,7 @@ unit_let = do ) ] - assertBool "assign statement" $ fail "x := while 1 do 2" + assertBool "assign statement" $ fail "x := while 1 do { 2 }" assertBool "assign function call" $ success @@ -116,10 +116,10 @@ unit_while = do let success = parseSuccessful while let fail = parseFailed while - assertBool "simple while" $ success "while 1 do x := x" [While (Const 1) [Let "x" (VariableName "x")]] + assertBool "simple while" $ success "while 1 do { x := x }" [While (Const 1) [Let "x" (VariableName "x")]] assertBool "complicated expression" $ success - "while 1 + 2 do x := x" + "while 1 + 2 do { x := x }" [ While (Application Addition (Const 1) (Const 2)) [Let "x" (VariableName "x")] @@ -127,7 +127,7 @@ unit_while = do assertBool "function call" $ success - "while f(1) do x := x" + "while f(1) do { x := x }" [ While (FunctionCall "f" [Const 1]) [Let "x" (VariableName "x")] @@ -136,7 +136,7 @@ unit_while = do assertBool "just while fails" $ fail "while" assertBool "just while-do failes" $ fail "while do" assertBool "without statement fail" $ fail "while 1 do" - assertBool "without condition fail" $ fail "while do x := x" + assertBool "without condition fail" $ fail "while do { x := x }" unit_if :: IO () unit_if = do @@ -145,7 +145,7 @@ unit_if = do assertBool "simple if" $ success - "if 1 then a(1) else a(2)" + "if 1 then { a(1) } else { a(2) }" [ If (Const 1) [FunctionCallStatement "a" [Const 1]] @@ -180,7 +180,7 @@ unit_statement = do assertBool "multiplie statements" $ success "x := a; y := b" [Let "x" $ VariableName "a", Let "y" $ VariableName "b"] assertBool "while with long body" $ success - "while 1 do x := a; y := b" + "while 1 do { x := a; y := b }" [ While (Const 1) [ Let "x" $ VariableName "a", @@ -219,5 +219,21 @@ unit_functionsDeclarations = do assertBool "With params" $ success "def f(a, b, c, d, e, f) { skip }" [FunctionDeclaration "f" (Function ["a", "b", "c", "d", "e", "f"] [Skip] Nothing)] assertBool "Identity function" $ success "def f(x) { skip } return x" [FunctionDeclaration "f" (Function ["x"] [Skip] (Just $ VariableName "x"))] - assertBool "Wierd argument name" $ fail "def f(asdas d sda ) {skip}" + assertBool "Weird argument name" $ fail "def f(asdas d sda ) {skip}" assertBool "Unclosed comma" $ fail "def f(a,) {skip}" + + assertBool "If in the middle of declaration" $ success "def f() { x := 0; if 0 == 0 then { y := y + 3 } else { z := z + 1 } } return y" + [FunctionDeclaration "f" ( + Function + [] + [ + Let "x" (Const 0), + If (Application Equals (Const 0) (Const 0)) + [ + Let "y" (Application Addition (VariableName "y") (Const 3)) + ] + [ + Let "z" (Application Addition (VariableName "z") (Const 1)) + ] + ] + (Just (VariableName "y")))] From 28db0601c681d1eef911d91c5b172be310e0b30a Mon Sep 17 00:00:00 2001 From: veron Date: Fri, 30 Dec 2022 16:44:46 +0200 Subject: [PATCH 65/75] refactor and add optimization support in console app --- app/Main.hs | 6 ++--- src/Analysis/AstToIr.hs | 2 +- src/Analysis/Live.hs | 29 ++++++++++++++++++++- src/Console.hs | 8 +++--- src/ConsoleParser.hs | 11 ++++++-- src/Execute.hs | 36 +++++++++++++++++++++----- test/Test/Live.hs | 57 ++++++++++------------------------------- 7 files changed, 88 insertions(+), 61 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 5755680..715c2e0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,12 +20,12 @@ main = do ) runAction :: Action -> IO () -runAction (Action (FileInput path) varContext) = do +runAction (Action (FileInput path) live varContext) = do i <- readFile path let context = newContext { Context.vars = [getVarContext varContext]} - evalStateT (runLoop $ lines i) context + evalStateT (runLoop live $ lines i) context -- выход: q -runAction (Action Interactive varContext) = +runAction (Action Interactive _ varContext) = let context = newContext { Context.vars = [getVarContext varContext]} in evalStateT readEvalWriteLoop context diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs index aecebb3..86c50f8 100644 --- a/src/Analysis/AstToIr.hs +++ b/src/Analysis/AstToIr.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} -module Analysis.AstToIr(astToIR, LabelMap) where +module Analysis.AstToIr(astToIR, LabelMap, isFunctionDeclaration) where import Compiler.Hoopl hiding ((<*>), LabelMap) import qualified Compiler.Hoopl as H ((<*>)) diff --git a/src/Analysis/Live.hs b/src/Analysis/Live.hs index e6c8ffc..f7e7608 100644 --- a/src/Analysis/Live.hs +++ b/src/Analysis/Live.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} {-# LANGUAGE ScopedTypeVariables, GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} module Analysis.Live where import Data.Maybe @@ -8,7 +9,9 @@ import qualified Data.Set as S import Compiler.Hoopl import Analysis.IR import Analysis.OptSupport -import Statement (Expression(VariableName)) +import Statement (Expression(VariableName), Statement) +import Analysis.AstToIr (astToIR) +import Analysis.IrToAst (irToAst) type Var = String type Live = S.Set Var @@ -55,3 +58,27 @@ deadAsstElim = mkBRewrite d d (Let x _) live | not (x `S.member` live) = return $ Just emptyGraph d _ _ = return Nothing + +type ErrorM = Either String + +liveOpt :: M [Proc] -> ErrorM (M [Proc]) +liveOpt procs = + return $ procs >>= mapM optProc + where + optProc proc@Proc {entry, body, args} = do + (body', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body mapEmpty + return $ proc { body = body' } + bwd = BwdPass { bp_lattice = liveLattice + , bp_transfer = liveness + , bp_rewrite = deadAsstElim + } + +optimizeLive :: [Statement] -> [Statement] +optimizeLive sts = do + case liveOpt (fmap snd (astToIR sts)) of + Left err -> error err + Right p -> do + let opted = runSimpleUniqueMonad $ runWithFuel fuel p + irToAst opted + where + fuel = 9999 \ No newline at end of file diff --git a/src/Console.hs b/src/Console.hs index c0db6b0..b2b68b8 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -1,7 +1,7 @@ module Console where import Context (Context(..)) -import Execute (run, executeREPL) +import Execute (run', executeREPL) import System.IO ( hFlush, stdout ) import Control.Monad ( when ) import Control.Monad.State ( MonadTrans(lift) ) @@ -12,9 +12,9 @@ readEvalWriteLoop = do input <- lift $ prompt "L: " when (input /= "q") $ executeREPL input >> unsetError >> readEvalWriteLoop -runLoop :: [String] -> StateT Context IO () -runLoop input = do - run input +runLoop :: Bool -> [String] -> StateT Context IO () +runLoop live input = do + run' live input context <- get maybe (pure ()) (lift . print) (Context.error context) diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index be27d41..4eecf7b 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -9,12 +9,14 @@ import Context (VarContext, setVarContext, emptyVarContext) -- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом data Action = Action { input :: Input - , vars :: [String] } + , liveness :: Bool + , vars :: [String] + } deriving (Show) -- Парсер аргументов командной строки actionParser :: Optparse.Parser Action -actionParser = Action <$> (inputParser <|> pure Interactive) <*> varsParser +actionParser = Action <$> (inputParser <|> pure Interactive)<*> liveOptParser <*> varsParser -- Тип входных данных data Input = FileInput FilePath -- Имя входного файла @@ -30,6 +32,11 @@ inputParser = FileInput <$> Optparse.strOption <> Optparse.metavar "INPUT" -- как аргумент этой опции называется в документации <> Optparse.help "Input file" ) +liveOptParser :: Optparse.Parser Bool +liveOptParser = Optparse.switch + ( Optparse.long "liveness-optimization" + <> Optparse.help "Whether to enable liveness optimization" ) + varsParser :: Optparse.Parser [String] varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar "VARS..." diff --git a/src/Execute.hs b/src/Execute.hs index cbc2ec8..5fa1f98 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,4 +1,4 @@ -module Execute (run, execute, executeREPL) where +module Execute (run, run', execute, executeREPL) where import Context ( Context(..), setErrorT ) import Control.Monad.State @@ -7,17 +7,39 @@ import Evaluate (evaluateStatements, evaluateExpression) import Grammar (parseStatement, REPLInput (..), parseStatementOrExpression) import Data.Maybe (isNothing) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Statement (Statement) +import Analysis.Live (optimizeLive) +import Analysis.AstToIr (isFunctionDeclaration) run :: [String] -> StateT Context IO () -run = foldr ((>>) . execute) (return ()) +run strs = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> pure () + Just sts -> foldr ((>>) . execute) (pure ()) sts -execute :: String -> StateT Context IO () -execute str = do +run' :: Bool -> [String] -> StateT Context IO () +run' optimize strs = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> pure () + Just sts -> foldr ((>>) . execute) (pure ()) (map optimizeLive sts ++ map (filter $ not . isFunctionDeclaration) sts) + + +execute :: [Statement] -> StateT Context IO () +execute statements = do context <- get guard ( isNothing (Context.error context) ) - case parseStatement str of - Left err -> setErrorT $ ParserError err - Right statements -> evaluateStatements statements + evaluateStatements statements + +parse :: [String] -> MaybeT (StateT Context IO) [[Statement]] +parse (x:xs) = do + case parseStatement x of + Left err -> do { lift $ setErrorT $ ParserError err; mzero } + Right parsed -> do + parsedTail <- parse xs + return $ parsed : parsedTail +parse [] = return [] executeREPL :: String -> StateT Context IO () executeREPL str = do diff --git a/test/Test/Live.hs b/test/Test/Live.hs index efe7dcb..ed8f60b 100644 --- a/test/Test/Live.hs +++ b/test/Test/Live.hs @@ -1,31 +1,14 @@ {-# LANGUAGE NamedFieldPuns #-} module Test.Live where -import Compiler.Hoopl -import Analysis.IR (Proc (..), M) import Statement (Statement (..), Function (Function), Expression (..), Operations (Equals, Addition)) import Grammar (parseStatement) import Data.Either (isLeft, fromRight) import Data.Maybe (fromJust) -import Analysis.AstToIr (astToIR) -import Analysis.IrToAst (irToAst) -import Analysis.Live (liveLattice, liveness, deadAsstElim) +import Analysis.Live (optimizeLive) import Test.Tasty.HUnit (assertEqual) -type ErrorM = Either String - -liveOpt :: M [Proc] -> ErrorM (M [Proc]) -liveOpt procs = - return $ procs >>= mapM optProc - where - optProc proc@Proc {entry, body, args} = do - (body', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body mapEmpty - return $ proc { body = body' } - bwd = BwdPass { bp_lattice = liveLattice - , bp_transfer = liveness - , bp_rewrite = deadAsstElim - } parse :: String -> Maybe [Statement] parse str = if any isLeft parsed @@ -36,20 +19,10 @@ parse str = if any isLeft parsed parsed = parse' $ lines str f b a = b ++ fromRight [] a -optimize :: String -> [Statement] -optimize text = do - case fmap astToIR (parse text) of - Nothing -> error "Parsing error" - Just ir -> case liveOpt (fmap snd ir) of - Left err -> error err - Right p -> do - let opted = runSimpleUniqueMonad $ runWithFuel fuel p - -- lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) p) - -- expected = runSimpleUniqueMonad $ runWithFuel fuel exps - -- TODO: get Instructions from [Proc] - irToAst opted - where - fuel = 9999 +optimizeFromString :: String -> [Statement] +optimizeFromString text = case parse text of + Nothing -> error "Parsing error" + Just ir -> optimizeLive ir increment :: String -> Expression -> Statement increment var expr = Let var (Application Addition (VariableName var) expr) @@ -66,9 +39,9 @@ unit_Liveness = do let expected3 = [FunctionDeclaration "f" (Function [] [Let "x" (Const 1)] (Just $ VariableName "x"))] - assertEqual "Liveness 1" (optimize testCode1) expected1 - assertEqual "Liveness 2" (optimize testCode2) expected2 - assertEqual "Liveness 3" (optimize testCode3) expected3 + assertEqual "Liveness 1" (optimizeFromString testCode1) expected1 + assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 + assertEqual "Liveness 3" (optimizeFromString testCode3) expected3 unit_ReadWrite :: IO () unit_ReadWrite = do @@ -78,8 +51,8 @@ unit_ReadWrite = do let testCode2 = "def f() { x := 0; write x }" let expected2 = [FunctionDeclaration "f" (Function [] [Let "x" $ Const 0, Write $ VariableName "x"] Nothing)] - assertEqual "Liveness 1" (optimize testCode1) expected1 - assertEqual "Liveness 2" (optimize testCode2) expected2 + assertEqual "Liveness 1" (optimizeFromString testCode1) expected1 + assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 unit_If :: IO () unit_If = do @@ -89,8 +62,8 @@ unit_If = do let testCode2 = "def f() { y := 0; z := 0; if z == 0 then { y := y + 3 } else { z := z + 1 } } return y + z" let expected2 = fromJust $ parse testCode2 - assertEqual "remove branch" (optimize testCode1) expected1 - assertEqual "unchanged" (optimize testCode2) expected2 + assertEqual "remove branch" (optimizeFromString testCode1) expected1 + assertEqual "unchanged" (optimizeFromString testCode2) expected2 unit_While :: IO () unit_While = do @@ -100,7 +73,5 @@ unit_While = do let testCode2 = "def f() { x := 0; while 0 == 0 do { x := x + 3 } }" let expected2 = [FunctionDeclaration "f" $ Function [] [While (Application Equals (Const 0) (Const 0)) []] Nothing] - print (optimize testCode2) - print expected2 - assertEqual "unchanged" (optimize testCode1) expected1 - assertEqual "remove x" (optimize testCode2) expected2 + assertEqual "unchanged" (optimizeFromString testCode1) expected1 + assertEqual "remove x" (optimizeFromString testCode2) expected2 From 9b6301d18cb4cc01a09379069e759a4d303e369c Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 16:27:42 +0100 Subject: [PATCH 66/75] basic property-based tests --- L-static-analyzer.cabal | 3 ++ package.yaml | 2 ++ src/Error.hs | 1 + src/Evaluate.hs | 40 ++++++++++++---------- test/Test.hs | 17 +++++++++- test/Test/ConsoleParser.hs | 11 ++++-- test/Test/Evaluate.hs | 6 +++- test/Test/Execute.hs | 18 +++++++--- test/Test/Parsers.hs | 35 ++++++++++++++------ test/Test/PropertyExpr.hs | 68 ++++++++++++++++++++++++++++++++++++++ 10 files changed, 164 insertions(+), 37 deletions(-) create mode 100644 test/Test/PropertyExpr.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index 821aa07..ea851b0 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -81,6 +81,7 @@ test-suite L-static-analyzer-test Test.Evaluate Test.Execute Test.Parsers + Test.PropertyExpr Paths_L_static_analyzer hs-source-dirs: test @@ -102,6 +103,8 @@ test-suite L-static-analyzer-test , tasty , tasty-discover , tasty-hedgehog + , tasty-hspec , tasty-hunit + , tasty-quickcheck , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 6831d26..bdce406 100644 --- a/package.yaml +++ b/package.yaml @@ -75,9 +75,11 @@ tests: - hspec - hspec-megaparsec - tasty + - tasty-hspec - tasty-hedgehog - tasty-hunit - tasty-discover + - tasty-quickcheck - L-static-analyzer - HUnit - tasty-hunit diff --git a/src/Error.hs b/src/Error.hs index da66fd7..4a4ff1a 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -11,4 +11,5 @@ data RuntimeError = ParserError ParsecError | CallOfVoidFunctionInExpression String | InvalidNumberOfArguments String Int Int | InvalidInput String + | DivisionByZero deriving (Show, Eq) \ No newline at end of file diff --git a/src/Evaluate.hs b/src/Evaluate.hs index eca169f..b53d2e1 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns #-} - module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression, evaluateList) where import Context (Context (..), getFunT, getVarT, loadFunStack, setFun, setVar, unloadFunStack, popInput, setErrorT, pushOutput, flush) @@ -9,7 +7,7 @@ import Statement (Expression (..), Function (..), Operations (..), Statement (.. import Text.Read (readMaybe) import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) import Data.Maybe (isNothing, fromJust, isJust) -import Error (RuntimeError(InvalidInput, UnexpectedEOF)) +import Error (RuntimeError(InvalidInput, UnexpectedEOF, DivisionByZero)) import GHC.IO.Handle (hIsOpen) import GHC.IO.Handle.FD (stdin) @@ -40,22 +38,28 @@ evaluateExpression (FunctionCall name argumentValues) = do evaluateExpression (Application op x y) = do x' <- evaluateExpression x y' <- evaluateExpression y - return $ unpack op x' y' + case unpack op x' y' of + Just v -> return v + Nothing -> do + ctx <- get + put ctx {Context.error = Just $ DivisionByZero} + mzero + where - unpack :: Operations -> (Int -> Int -> Int) - unpack Addition = (+) - unpack Subtraction = (-) - unpack Division = div - unpack Multiplication = (*) - unpack Modulo = mod - unpack Equals = fromBool .* (==) - unpack NotEquals = fromBool .* (/=) - unpack Greater = fromBool .* (>) - unpack GreaterOrEquals = fromBool .* (>=) - unpack Less = fromBool .* (<) - unpack LessOrEquals = fromBool .* (<=) - unpack LazyAnd = lazyAnd - unpack LazyOr = lazyOr + unpack :: Operations -> (Int -> Int -> Maybe Int) + unpack Addition = Just .* (+) + unpack Subtraction = Just .* (-) + unpack Division = \a b -> if b == 0 then Nothing else Just $ a `div` b + unpack Multiplication = Just .* (*) + unpack Modulo = \a b -> if b == 0 then Nothing else Just $ a `mod` b + unpack Equals = Just . fromBool .* (==) + unpack NotEquals = Just . fromBool .* (/=) + unpack Greater = Just . fromBool .* (>) + unpack GreaterOrEquals = Just . fromBool .* (>=) + unpack Less = Just . fromBool .* (<) + unpack LessOrEquals = Just . fromBool .* (<=) + unpack LazyAnd = Just .* lazyAnd + unpack LazyOr = Just .* lazyOr lazyAnd :: Int -> Int -> Int lazyAnd lft rgt = if lft == 0 then 0 else boolToInt rgt diff --git a/test/Test.hs b/test/Test.hs index d7a0a67..e63b1b7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1 +1,16 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} \ No newline at end of file +import Test.Tasty + +import qualified Test.PropertyExpr +import qualified Test.Parsers +import qualified Test.Execute +import qualified Test.Evaluate +import qualified Test.ConsoleParser + +main :: IO () +main = defaultMain (testGroup "All Tests" + [ testGroup "Property expr" Test.PropertyExpr.props + , testGroup "Parsers" Test.Parsers.unitTests + , testGroup "Execute" Test.Execute.unitTests + , testGroup "Evaluate" Test.Evaluate.unitTests + , testGroup "Console parser" Test.ConsoleParser.unitTests + ]) \ No newline at end of file diff --git a/test/Test/ConsoleParser.hs b/test/Test/ConsoleParser.hs index cae2bae..ae372ba 100644 --- a/test/Test/ConsoleParser.hs +++ b/test/Test/ConsoleParser.hs @@ -2,7 +2,8 @@ module Test.ConsoleParser where import Grammar (Parser) import ConsoleParser (varArgParser, getVarContext) -import Test.HUnit +import Test.Tasty.HUnit +import Test.Tasty import Text.Megaparsec import Context (VarContext(..)) import qualified Data.Map as Map @@ -32,7 +33,13 @@ unit_varArgParser = do varContextComp :: [String] -> [(String, Int)] -> Bool varContextComp inp cxt = getVarContext inp == VarContext { varContext = Map.fromList cxt } -unit_getVarContext :: IO () +unit_getVarContext :: Assertion unit_getVarContext = do assertBool "1" $ varContextComp ["var=234", "var2=0"] [("var", 234), ("var2", 0)] assertBool "2" $ varContextComp ["var=24", "var=0"] [("var", 24)] + +unitTests :: [TestTree] +unitTests = + [ testCase "var arg parser" unit_varArgParser + , testCase "get var context" unit_getVarContext + ] \ No newline at end of file diff --git a/test/Test/Evaluate.hs b/test/Test/Evaluate.hs index db8d115..335eb75 100644 --- a/test/Test/Evaluate.hs +++ b/test/Test/Evaluate.hs @@ -2,7 +2,8 @@ module Test.Evaluate where import Evaluate (evaluateList) import Context (newContext) -import Test.HUnit +import Test.Tasty.HUnit +import Test.Tasty import Text.Megaparsec import Statement (Expression(..)) import Control.Monad.State (evalStateT) @@ -21,3 +22,6 @@ unit_evaluateExprList = do assert "failure" $ testEvaluateList [VariableName "var"] Nothing assert "failure" $ testEvaluateList [Const 1, VariableName "var"] Nothing assert "failure" $ testEvaluateList [VariableName "var", Const 2] Nothing + +unitTests :: [TestTree] +unitTests = [ testCase "evaluate expr list" unit_evaluateExprList ] \ No newline at end of file diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index 73de317..c102d21 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -8,7 +8,8 @@ import Evaluate (evaluateStatements) import GHC.IO.Handle (hClose) import GHC.IO.Handle.FD (stdin) import Statement (Expression (..), Operations (..), Statement (..)) -import Test.Tasty.HUnit (assertBool) +import Test.Tasty.HUnit (assertBool, Assertion, testCase) +import Test.Tasty import Execute(run) checkOutput :: Context -> [String] -> Bool @@ -20,7 +21,7 @@ checkError cxt err = Context.error cxt == Just err noFlushContext :: Context noFlushContext = newContext {flushEnabled = False} -unit_executeWrite :: IO () +unit_executeWrite :: Assertion unit_executeWrite = do let writeConst = Write (Const 1) let writeVar = Write (VariableName "var") @@ -38,7 +39,7 @@ unit_executeWrite = do assertBool "write var failure" $ checkOutput exitContext [] assertBool "write var failure" $ checkError exitContext (VarNotFound "var") -unit_executeRead :: IO () +unit_executeRead :: Assertion unit_executeRead = do let readVar = Read "var" let writeConst = Write (Const 1) @@ -53,7 +54,7 @@ unit_executeRead = do exitContext <- execStateT (evaluateStatements [readVar]) noFlushContext assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF -unit_basicWhileTest :: IO () +unit_basicWhileTest :: Assertion unit_basicWhileTest = do -- let code = "x := 1\n" ++ "write x + 10\n" ++ "while x > 0 do write x; x := x - 1" ++ "write x" let code = @@ -70,7 +71,7 @@ unit_basicWhileTest = do exitContext <- execStateT (evaluateStatements code) context assertBool "test successfull" $ checkOutput exitContext ["11", "1", "0"] -unit_functions :: IO () +unit_functions :: Assertion unit_functions = do let code = [ @@ -105,3 +106,10 @@ unit_functions = do "7" ] +unitTests :: [TestTree] +unitTests = + [ testCase "execute write" unit_executeWrite + , testCase "execute read" unit_executeRead + , testCase "basic while test" unit_basicWhileTest + , testCase "functions" unit_functions + ] \ No newline at end of file diff --git a/test/Test/Parsers.hs b/test/Test/Parsers.hs index 8f701b8..fe669ce 100644 --- a/test/Test/Parsers.hs +++ b/test/Test/Parsers.hs @@ -2,9 +2,9 @@ module Test.Parsers where import Grammar import Statement -import Test.HUnit +import Test.Tasty +import Test.Tasty.HUnit import Text.Megaparsec -import Grammar (REPLInput(..)) parseSuccessful :: Eq a => Parser a -> String -> a -> Bool parseSuccessful parser line result = case parse (parser <* eof) "" line of @@ -16,7 +16,7 @@ parseFailed parser line = case parse (parser <* eof) "" line of Left _ -> True Right _ -> False -unit_const :: IO () +unit_const :: Assertion unit_const = do let succConst = parseSuccessful constValue let failConst = parseFailed constValue @@ -26,7 +26,7 @@ unit_const = do assertBool "const parser failed" $ succConst "1234567" (Const 1234567) assertBool "const parser failed" $ failConst "ahahahahh1234" -unit_var_name :: IO () +unit_var_name :: Assertion unit_var_name = do let succVar = parseSuccessful varName let failVar = parseFailed varName @@ -42,7 +42,7 @@ unit_var_name = do assertBool "bad keywords are banned" $ failVar "then" assertBool "bad keywords are banned" $ failVar "else" -unit_expr :: IO () +unit_expr :: Assertion unit_expr = do let succExpr = parseSuccessful expression let failExpr = parseFailed expression @@ -66,7 +66,7 @@ unit_expr = do assertBool "fails on unary" $ failExpr "+1" assertBool "fails on bad expr" $ failExpr "1+2++-" -unit_let :: IO () +unit_let :: Assertion unit_let = do let success = parseSuccessful letVariable let fail = parseFailed letVariable @@ -111,7 +111,7 @@ unit_let = do ) ] -unit_while :: IO () +unit_while :: Assertion unit_while = do let success = parseSuccessful while let fail = parseFailed while @@ -138,7 +138,7 @@ unit_while = do assertBool "without statement fail" $ fail "while 1 do" assertBool "without condition fail" $ fail "while do { x := x }" -unit_if :: IO () +unit_if :: Assertion unit_if = do let success = parseSuccessful ifThenElse let fail = parseFailed ifThenElse @@ -154,7 +154,7 @@ unit_if = do assertBool "if fails with statement in condition" $ fail "if x := 1 then a 1 else a 2" -unit_statement :: IO () +unit_statement :: Assertion unit_statement = do let success = parseSuccessful statement let fail = parseFailed statement @@ -200,7 +200,7 @@ unit_expressionOrStatement = do Left _ -> True Right _ -> False -unit_functionsDeclarations :: IO () +unit_functionsDeclarations :: Assertion unit_functionsDeclarations = do let success = parseSuccessful functionDeclaration let fail = parseFailed functionDeclaration @@ -237,3 +237,18 @@ unit_functionsDeclarations = do ] ] (Just (VariableName "y")))] + + + +unitTests :: [TestTree] +unitTests = + [ testCase "Const" unit_const + , testCase "Var Name" unit_var_name + , testCase "Expr" unit_expr + , testCase "Functions Declarations" unit_functionsDeclarations + , testCase "If" unit_if + , testCase "Let" unit_let + , testCase "Statement" unit_statement + , testCase "While" unit_while + , testCase "Expression or Statement" unit_expressionOrStatement + ] \ No newline at end of file diff --git a/test/Test/PropertyExpr.hs b/test/Test/PropertyExpr.hs new file mode 100644 index 0000000..9bf1739 --- /dev/null +++ b/test/Test/PropertyExpr.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE BangPatterns #-} +module Test.PropertyExpr where + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Hedgehog +import Statement +import Evaluate (evaluateExpression) +import Context (newContext) +import Control.Monad.State +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog + +genOp :: Gen Operations +genOp = Gen.element [Addition, Subtraction, Multiplication, Division, Modulo, Less, Greater, LessOrEquals, GreaterOrEquals, Equals, NotEquals] + +genExpr :: Int -> Gen Expression +genExpr n = + Gen.recursive + Gen.choice + [ + numGen + ] + [ + binOpGen + ] + where + binOpGen = do + op <- genOp + Gen.subterm2 (genExpr n) (genExpr n) (Application op) + numGen = Const <$> Gen.int (Range.constant 0 n) + + +evalExpr :: Expression -> Maybe Int +evalExpr (Const x) = Just x +evalExpr (Application op x y) = do + x' <- evalExpr x + y' <- evalExpr y + getF op x' y' + where + getF :: Operations -> (Int -> Int -> Maybe Int) + getF Addition = \a b -> Just $ a + b + getF Subtraction = \a b -> Just $ a - b + getF Multiplication = \a b -> Just $ a * b + getF Modulo = \a b -> if b == 0 then Nothing else Just $ a `mod` b + getF Division = \a b -> if b == 0 then Nothing else Just $ a `div` b + getF Less = \a b -> Just $ if a < b then 1 else 0 + getF Greater = \a b -> Just $ if a > b then 1 else 0 + getF LessOrEquals = \a b -> Just $ if a <= b then 1 else 0 + getF GreaterOrEquals = \a b -> Just $ if a >= b then 1 else 0 + getF Equals = \a b -> Just $ if a == b then 1 else 0 + getF NotEquals = \a b -> Just $ if a /= b then 1 else 0 + getF _ = error "operation not supported" +evalExpr _ = error "expression not supported" + +prop_eval_correct :: Property +prop_eval_correct = property $ do + expr <- forAll $ genExpr 1000 + let !res = evalExpr expr + let ctx = newContext + let a = evalStateT (runMaybeT (evaluateExpression expr)) ctx + res' <- liftIO a + res === res' + +props :: [TestTree] +props = + [ testProperty "Test correctness of expression evaluation" prop_eval_correct ] \ No newline at end of file From f08e44b99de25f2a3513f78809b33294a415cc94 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 19:32:19 +0100 Subject: [PATCH 67/75] first sketch of static analysis property testing --- L-static-analyzer.cabal | 1 + test/Test/PropertyExpr.hs | 17 +++--- test/Test/PropertyOptimizing.hs | 92 +++++++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 8 deletions(-) create mode 100644 test/Test/PropertyOptimizing.hs diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index ea851b0..e7f09d1 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -82,6 +82,7 @@ test-suite L-static-analyzer-test Test.Execute Test.Parsers Test.PropertyExpr + Test.PropertyOptimizing Paths_L_static_analyzer hs-source-dirs: test diff --git a/test/Test/PropertyExpr.hs b/test/Test/PropertyExpr.hs index 9bf1739..37f298e 100644 --- a/test/Test/PropertyExpr.hs +++ b/test/Test/PropertyExpr.hs @@ -15,21 +15,22 @@ import Test.Tasty.Hedgehog genOp :: Gen Operations genOp = Gen.element [Addition, Subtraction, Multiplication, Division, Modulo, Less, Greater, LessOrEquals, GreaterOrEquals, Equals, NotEquals] -genExpr :: Int -> Gen Expression -genExpr n = +genExpr :: Int -> [String] -> Gen Expression +genExpr n vars = Gen.recursive Gen.choice - [ - numGen - ] + nonRecGens [ binOpGen ] where binOpGen = do op <- genOp - Gen.subterm2 (genExpr n) (genExpr n) (Application op) + Gen.subterm2 (genExpr n vars) (genExpr n vars) (Application op) numGen = Const <$> Gen.int (Range.constant 0 n) + varGen = VariableName <$> Gen.element vars + + nonRecGens = numGen : ([varGen | not (null vars)]) evalExpr :: Expression -> Maybe Int @@ -56,7 +57,7 @@ evalExpr _ = error "expression not supported" prop_eval_correct :: Property prop_eval_correct = property $ do - expr <- forAll $ genExpr 1000 + expr <- forAll $ genExpr 1000 [] let !res = evalExpr expr let ctx = newContext let a = evalStateT (runMaybeT (evaluateExpression expr)) ctx @@ -64,5 +65,5 @@ prop_eval_correct = property $ do res === res' props :: [TestTree] -props = +props = [ testProperty "Test correctness of expression evaluation" prop_eval_correct ] \ No newline at end of file diff --git a/test/Test/PropertyOptimizing.hs b/test/Test/PropertyOptimizing.hs new file mode 100644 index 0000000..b085eb0 --- /dev/null +++ b/test/Test/PropertyOptimizing.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Test.PropertyOptimizing where + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Hedgehog +import Control.Monad.State +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog +import Test.PropertyExpr (genExpr) +import qualified Statement as A +import Data.List (nub) + +genVarName :: [String] -> Int -> Gen String +genVarName _ 0 = error "too short" +genVarName vars x = Gen.choice generators + where + genNew = do + firstLetter <- Gen.alpha + suffix <- Gen.string (Range.singleton $ x - 1) Gen.alphaNum + return $ firstLetter : suffix + genExisting = Gen.element vars + generators = genNew : ([genExisting | not (null vars)]) + + +genLet :: [String] -> Int -> Int -> Gen A.Statement +genLet vars len limVal = A.Let <$> genVarName vars len <*> genExpr limVal vars + + +genStatement :: [String] -> Int -> Int -> Int -> Gen (A.Statement, [String]) +genStatement vars bodyLen lenVar limVal = Gen.choice [genLet', genWrite, genIf, genSkip] + where + genLet' :: Gen (A.Statement, [String]) + genLet' = do + l <- genLet vars lenVar limVal + let (A.Let name _) = l + return (l, nub $ name : vars) + + genFunCall :: Gen (A.Statement, [String]) + genFunCall = error "unsupported" -- due to my laziness + + genWrite :: Gen (A.Statement, [String]) + genWrite = do + expr <- genExpr limVal vars + return (A.Write expr, vars) + + genRead :: Gen (A.Statement, [String]) + genRead = do + name <- genVarName vars lenVar + return (A.Read name, nub $ name : vars) + + genWhile :: Gen (A.Statement, [String]) -- generates a lot of infinity loops + genWhile = do + expr <- genExpr limVal vars + (body, vars') <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id + return (A.While expr body, nub (vars' ++ vars)) + + genIf :: Gen (A.Statement, [String]) + genIf = do + expr <- genExpr limVal vars + (t, vars') <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id + let vars'' = nub (vars' ++ vars) + (f, vars''') <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id + return (A.If expr t f, nub (vars''' ++ vars'')) + + genSkip :: Gen (A.Statement, [String]) + genSkip = return (A.Skip, vars) + +genStatements :: [String] -> Int -> Int -> Int -> Gen ([A.Statement], [String]) +genStatements vars bodyLen lenVar limVal = do + len <- Gen.int $ Range.constant 0 bodyLen + helper len vars bodyLen lenVar limVal + where + helper :: Int -> [String] -> Int -> Int -> Int -> Gen ([A.Statement], [String]) + helper 0 _ _ _ _ = return ([], []) + helper x vars bodyLen lenVar limVal = do + (prefix, vars') <- helper (x - 1) vars bodyLen lenVar limVal + let vars'' = nub (vars ++ vars') + (s, vars''') <- genStatement vars'' bodyLen lenVar limVal + return (prefix ++ [s], nub (vars''' ++ vars'')) + +genFunction :: Int -> Int -> Int -> Int -> Gen A.Function -- all functions are void due to my laziness +genFunction argsNum bodyLen lenVar limVal = do + args <- Gen.subterm (Gen.list (Range.constant 0 argsNum) (genVarName [] lenVar)) id + (body, _) <- Gen.subterm (genStatements args bodyLen lenVar limVal) id + return $ A.Function args body Nothing + +genAst :: Int -> Int -> Int -> Int -> Int -> Gen [A.Statement] +genAst numOfFun argsNum bodyLen lenVar limVal = Gen.list (Range.constant 1 numOfFun) genFunDecl + where + genFunDecl = A.FunctionDeclaration <$> genVarName [] lenVar <*> genFunction argsNum bodyLen lenVar limVal \ No newline at end of file From 5b612de28ea3eab98a570675e22fcccf19ae0917 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 20:06:44 +0100 Subject: [PATCH 68/75] property-based testing is ready --- L-static-analyzer.cabal | 3 ++ test/Test.hs | 2 ++ test/Test/PropertyOptimizing.hs | 56 +++++++++++++++++++++++++++++++-- 3 files changed, 58 insertions(+), 3 deletions(-) diff --git a/L-static-analyzer.cabal b/L-static-analyzer.cabal index e7f09d1..dd63f2d 100644 --- a/L-static-analyzer.cabal +++ b/L-static-analyzer.cabal @@ -28,6 +28,8 @@ library Analysis.AstToIr Analysis.IR Analysis.IrToAst + Analysis.Live + Analysis.OptSupport Console ConsoleParser Context @@ -80,6 +82,7 @@ test-suite L-static-analyzer-test Test.ConsoleParser Test.Evaluate Test.Execute + Test.Live Test.Parsers Test.PropertyExpr Test.PropertyOptimizing diff --git a/test/Test.hs b/test/Test.hs index e63b1b7..bed83fa 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -5,6 +5,7 @@ import qualified Test.Parsers import qualified Test.Execute import qualified Test.Evaluate import qualified Test.ConsoleParser +import qualified Test.PropertyOptimizing main :: IO () main = defaultMain (testGroup "All Tests" @@ -13,4 +14,5 @@ main = defaultMain (testGroup "All Tests" , testGroup "Execute" Test.Execute.unitTests , testGroup "Evaluate" Test.Evaluate.unitTests , testGroup "Console parser" Test.ConsoleParser.unitTests + , testGroup "Property-based live optimization" Test.PropertyOptimizing.props ]) \ No newline at end of file diff --git a/test/Test/PropertyOptimizing.hs b/test/Test/PropertyOptimizing.hs index b085eb0..fa4cfe8 100644 --- a/test/Test/PropertyOptimizing.hs +++ b/test/Test/PropertyOptimizing.hs @@ -5,12 +5,14 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Hedgehog import Control.Monad.State -import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) import Test.Tasty (TestTree) import Test.Tasty.Hedgehog import Test.PropertyExpr (genExpr) import qualified Statement as A import Data.List (nub) +import Analysis.Live (optimizeLive) +import qualified Context +import Execute (execute) genVarName :: [String] -> Int -> Gen String genVarName _ 0 = error "too short" @@ -83,10 +85,58 @@ genStatements vars bodyLen lenVar limVal = do genFunction :: Int -> Int -> Int -> Int -> Gen A.Function -- all functions are void due to my laziness genFunction argsNum bodyLen lenVar limVal = do args <- Gen.subterm (Gen.list (Range.constant 0 argsNum) (genVarName [] lenVar)) id - (body, _) <- Gen.subterm (genStatements args bodyLen lenVar limVal) id + (body, _) <- Gen.subterm (genStatements args bodyLen lenVar limVal) id return $ A.Function args body Nothing genAst :: Int -> Int -> Int -> Int -> Int -> Gen [A.Statement] genAst numOfFun argsNum bodyLen lenVar limVal = Gen.list (Range.constant 1 numOfFun) genFunDecl where - genFunDecl = A.FunctionDeclaration <$> genVarName [] lenVar <*> genFunction argsNum bodyLen lenVar limVal \ No newline at end of file + genFunDecl = A.FunctionDeclaration <$> genVarName [] lenVar <*> genFunction argsNum bodyLen lenVar limVal + +noFlushContext :: Context.Context +noFlushContext = Context.newContext {Context.flushEnabled = False} + +declToCall :: A.Statement -> (String, Int) +declToCall (A.FunctionDeclaration name (A.Function args _ _)) = (name, length args) +declToCall _ = error "unsupported" + +genFunCalls :: [(String, Int)] -> Int -> Int -> Gen [A.Statement] +genFunCalls funs amount limVar = Gen.list (Range.singleton amount) genCall + where + genArgs :: Int -> Gen [A.Expression] + genArgs x = Gen.list (Range.singleton x) (genExpr limVar []) + + genCall :: Gen A.Statement + genCall = do + (name, argsCnt) <- Gen.element funs + args <- genArgs argsCnt + return $ A.FunctionCallStatement name args + +prop_is_eval_ok :: Property +prop_is_eval_ok = property $ do + let numOfFuns = 5 + let argsNum = 3 + let bodyLen = 3 + let lenVar = 2 + let limVar = 1000 + ast <- forAll $ genAst numOfFuns argsNum bodyLen lenVar limVar + let funParams = map declToCall ast + let optAst = optimizeLive ast + let ctx1 = noFlushContext {Context.input = Context.Buffer []} + let ctx2 = noFlushContext {Context.input = Context.Buffer []} + + ctx1' <- liftIO $ execStateT (execute ast) ctx1 + ctx2' <- liftIO $ execStateT (execute optAst) ctx2 + + let callsAmount = 10 + + calls <- forAll $ genFunCalls funParams callsAmount limVar + + ctx1'' <- liftIO $ execStateT (execute calls) ctx1' + ctx2'' <- liftIO $ execStateT (execute calls) ctx2' + Context.output ctx1'' === Context.output ctx2'' + + +props :: [TestTree] +props = + [ testProperty "Test correctness of liveness optimization" prop_is_eval_ok ] \ No newline at end of file From 9a7df78fdf1fe8a8d6b896386d3ef5e2fb17ccd2 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 20:44:48 +0100 Subject: [PATCH 69/75] YOU SHALL NOT FAIL --- src/Statement.hs | 2 +- test/Test.hs | 4 +++- test/Test/Live.hs | 17 +++++++++++++---- test/Test/PropertyExpr.hs | 2 +- test/Test/PropertyOptimizing.hs | 21 +++++++++++++-------- 5 files changed, 31 insertions(+), 15 deletions(-) diff --git a/src/Statement.hs b/src/Statement.hs index ea9233e..e9a1171 100644 --- a/src/Statement.hs +++ b/src/Statement.hs @@ -77,7 +77,7 @@ instance Show Statement where show (Write x) = "write " ++ show x show (Read x) = "read " ++ x show (While e s) = "while (" ++ show e ++ ") " ++ bodyToString s - show (If e t f) = "If " ++ show e ++ " then " ++ bodyToString t ++ " else " ++ bodyToString f + show (If e t f) = "if " ++ show e ++ " then " ++ bodyToString t ++ " else " ++ bodyToString f show Skip = "skip" data Function = Function [String] [Statement] (Maybe Expression) deriving (Eq) diff --git a/test/Test.hs b/test/Test.hs index bed83fa..22a9bd3 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -6,6 +6,7 @@ import qualified Test.Execute import qualified Test.Evaluate import qualified Test.ConsoleParser import qualified Test.PropertyOptimizing +import qualified Test.Live main :: IO () main = defaultMain (testGroup "All Tests" @@ -14,5 +15,6 @@ main = defaultMain (testGroup "All Tests" , testGroup "Execute" Test.Execute.unitTests , testGroup "Evaluate" Test.Evaluate.unitTests , testGroup "Console parser" Test.ConsoleParser.unitTests - , testGroup "Property-based live optimization" Test.PropertyOptimizing.props + , testGroup "Liveness optimization" Test.Live.unitTests + , testGroup "Property-based liveness optimization" Test.PropertyOptimizing.props ]) \ No newline at end of file diff --git a/test/Test/Live.hs b/test/Test/Live.hs index ed8f60b..0f39239 100644 --- a/test/Test/Live.hs +++ b/test/Test/Live.hs @@ -7,7 +7,8 @@ import Data.Either (isLeft, fromRight) import Data.Maybe (fromJust) import Analysis.Live (optimizeLive) -import Test.Tasty.HUnit (assertEqual) +import Test.Tasty.HUnit (assertEqual, Assertion, testCase) +import Test.Tasty parse :: String -> Maybe [Statement] @@ -27,7 +28,7 @@ optimizeFromString text = case parse text of increment :: String -> Expression -> Statement increment var expr = Let var (Application Addition (VariableName var) expr) -unit_Liveness :: IO () +unit_Liveness :: Assertion unit_Liveness = do let testCode1 = "def f() { x := 5; y := x } return 1" let expected1 = [FunctionDeclaration "f" (Function [] [] (Just $ Const 1))] @@ -43,7 +44,7 @@ unit_Liveness = do assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 assertEqual "Liveness 3" (optimizeFromString testCode3) expected3 -unit_ReadWrite :: IO () +unit_ReadWrite :: Assertion unit_ReadWrite = do let testCode1 = "def f() { read x }" let expected1 = [FunctionDeclaration "f" (Function [] [Read "x"] Nothing)] @@ -54,7 +55,7 @@ unit_ReadWrite = do assertEqual "Liveness 1" (optimizeFromString testCode1) expected1 assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 -unit_If :: IO () +unit_If :: Assertion unit_If = do let testCode1 = "def f() { y := 0; z := 0; if z == 0 then { y := y + 3 } else { z := z + 1 } } return y" let expected1 = [FunctionDeclaration "f" (Function [] [Let "y" (Const 0), Let "z" (Const 0), If (Application Equals (VariableName "z") (Const 0)) [increment "y" (Const 3)] []] (Just $ VariableName "y"))] @@ -75,3 +76,11 @@ unit_While = do assertEqual "unchanged" (optimizeFromString testCode1) expected1 assertEqual "remove x" (optimizeFromString testCode2) expected2 + +unitTests :: [TestTree] +unitTests = + [ testCase "While" unit_While + , testCase "If" unit_If + , testCase "Read/Write" unit_ReadWrite + , testCase "Liveness" unit_Liveness + ] \ No newline at end of file diff --git a/test/Test/PropertyExpr.hs b/test/Test/PropertyExpr.hs index 37f298e..ba6320d 100644 --- a/test/Test/PropertyExpr.hs +++ b/test/Test/PropertyExpr.hs @@ -27,7 +27,7 @@ genExpr n vars = binOpGen = do op <- genOp Gen.subterm2 (genExpr n vars) (genExpr n vars) (Application op) - numGen = Const <$> Gen.int (Range.constant 0 n) + numGen = Const <$> Gen.int (Range.constant 1 n) varGen = VariableName <$> Gen.element vars nonRecGens = numGen : ([varGen | not (null vars)]) diff --git a/test/Test/PropertyOptimizing.hs b/test/Test/PropertyOptimizing.hs index fa4cfe8..0cc9b59 100644 --- a/test/Test/PropertyOptimizing.hs +++ b/test/Test/PropertyOptimizing.hs @@ -13,6 +13,7 @@ import Data.List (nub) import Analysis.Live (optimizeLive) import qualified Context import Execute (execute) +import Data.Maybe genVarName :: [String] -> Int -> Gen String genVarName _ 0 = error "too short" @@ -61,10 +62,9 @@ genStatement vars bodyLen lenVar limVal = Gen.choice [genLet', genWrite, genIf, genIf :: Gen (A.Statement, [String]) genIf = do expr <- genExpr limVal vars - (t, vars') <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id - let vars'' = nub (vars' ++ vars) - (f, vars''') <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id - return (A.If expr t f, nub (vars''' ++ vars'')) + (t, _) <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id + (f, _) <- Gen.subterm (genStatements vars bodyLen lenVar limVal) id + return (A.If expr t f, vars) genSkip :: Gen (A.Statement, [String]) genSkip = return (A.Skip, vars) @@ -112,11 +112,16 @@ genFunCalls funs amount limVar = Gen.list (Range.singleton amount) genCall args <- genArgs argsCnt return $ A.FunctionCallStatement name args +isError :: MonadTest m => Context.Context -> Context.Context -> m () +isError ctx1@Context.Context {Context.error = x} ctx2@Context.Context {Context.error = y} = case x of + Just _ -> if isJust y then success else failure + Nothing -> if isNothing y then Context.output ctx1 === Context.output ctx2 else failure + prop_is_eval_ok :: Property prop_is_eval_ok = property $ do - let numOfFuns = 5 + let numOfFuns = 3 let argsNum = 3 - let bodyLen = 3 + let bodyLen = 2 let lenVar = 2 let limVar = 1000 ast <- forAll $ genAst numOfFuns argsNum bodyLen lenVar limVar @@ -128,13 +133,13 @@ prop_is_eval_ok = property $ do ctx1' <- liftIO $ execStateT (execute ast) ctx1 ctx2' <- liftIO $ execStateT (execute optAst) ctx2 - let callsAmount = 10 + let callsAmount = 2 calls <- forAll $ genFunCalls funParams callsAmount limVar ctx1'' <- liftIO $ execStateT (execute calls) ctx1' ctx2'' <- liftIO $ execStateT (execute calls) ctx2' - Context.output ctx1'' === Context.output ctx2'' + isError ctx1'' ctx2'' props :: [TestTree] From 1cc97f247f9ad65cab3fe0013e1a298e9e74b4e3 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 20:56:23 +0100 Subject: [PATCH 70/75] test fixes --- test/Test/PropertyOptimizing.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/Test/PropertyOptimizing.hs b/test/Test/PropertyOptimizing.hs index 0cc9b59..1f58589 100644 --- a/test/Test/PropertyOptimizing.hs +++ b/test/Test/PropertyOptimizing.hs @@ -114,15 +114,15 @@ genFunCalls funs amount limVar = Gen.list (Range.singleton amount) genCall isError :: MonadTest m => Context.Context -> Context.Context -> m () isError ctx1@Context.Context {Context.error = x} ctx2@Context.Context {Context.error = y} = case x of - Just _ -> if isJust y then success else failure + Just _ -> success -- def f() { a := 1 / 0 } should fail in unoptimized and work in optimized Nothing -> if isNothing y then Context.output ctx1 === Context.output ctx2 else failure prop_is_eval_ok :: Property prop_is_eval_ok = property $ do - let numOfFuns = 3 - let argsNum = 3 - let bodyLen = 2 - let lenVar = 2 + let numOfFuns = 7 + let argsNum = 5 + let bodyLen = 3 + let lenVar = 3 let limVar = 1000 ast <- forAll $ genAst numOfFuns argsNum bodyLen lenVar limVar let funParams = map declToCall ast @@ -133,7 +133,7 @@ prop_is_eval_ok = property $ do ctx1' <- liftIO $ execStateT (execute ast) ctx1 ctx2' <- liftIO $ execStateT (execute optAst) ctx2 - let callsAmount = 2 + let callsAmount = 100 calls <- forAll $ genFunCalls funParams callsAmount limVar From 94d89662d1eb395cae0406c94eb770fbb3e7b11a Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 21:18:13 +0100 Subject: [PATCH 71/75] README new version --- README.md | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 65 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ebc4c26..0a5e235 100644 --- a/README.md +++ b/README.md @@ -1 +1,65 @@ -# L programming language & static analyzer \ No newline at end of file +# L programming language & static analyzer + +## L Syntax + +L is a simple imperative programming language which supports basic statements: + +* Variable assignment: ` := ` +* `if`: + +```text +if a > b then { write a; b := a } else { write b; a := b } +``` + +That generally is + +```text +if then { } else { } +``` + +*`while`: + +```text +while x > 10 do { write x; x := x - 1 } +``` + +That generally is + +```text +while do { } +``` + +* `Skip` -- no-op command +* `Write ` and `Read ` commands +* Functions: + * where declaration `def (, ,...) { }` + or `def (, ,...) { } return ` + * and call is `(arg1, arg2,...)` where `arg` is an expression. Call also supported in + expressions: `x := 2 + sum(2, 3)`. + +Expressions support variable access, function calls and several binary operations +such: `+, -, *, /, %, >, >=, ==, !=, <=, <, &&, ||`. + +### Examples + +Factorial function: + +```text +def f(x) { ans := 1; while (x > 0) do { ans := ans * x; x := x - 1 } } return ans +``` + +Recursive fibonacci numbers: + +```text +def fib(x) { ans := 1; if (x < 2) then { skip } else { ans := fib(x - 1) + fib(x - 2) } } return ans +``` + +## Usage of CLI app + +TODO + +## Static Analysis + +We wrote a static analyzer with liveness optimization that eliminate dead code. It could make code faster in situations +when we compute unused in future code. E.g.: TODO + From 415b520079c497876f9e94073d8d655137c0aba7 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 21:18:38 +0100 Subject: [PATCH 72/75] README new version --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 0a5e235..6034cdd 100644 --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ That generally is if then { } else { } ``` -*`while`: +* `while`: ```text while x > 10 do { write x; x := x - 1 } From b7f1c46ee850b995d97f507850bb524fecb92d34 Mon Sep 17 00:00:00 2001 From: khbminus Date: Fri, 30 Dec 2022 21:52:50 +0100 Subject: [PATCH 73/75] README update & bug fixes --- README.md | 30 +++++++++++++++++++++++++++--- src/Evaluate.hs | 6 ++++-- src/Execute.hs | 2 +- 3 files changed, 32 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 6034cdd..59212e2 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ Factorial function: def f(x) { ans := 1; while (x > 0) do { ans := ans * x; x := x - 1 } } return ans ``` -Recursive fibonacci numbers: +Recursive Fibonacci numbers: ```text def fib(x) { ans := 1; if (x < 2) then { skip } else { ans := fib(x - 1) + fib(x - 2) } } return ans @@ -56,10 +56,34 @@ def fib(x) { ans := 1; if (x < 2) then { skip } else { ans := fib(x - 1) + fib(x ## Usage of CLI app -TODO +### REPL + +If you run the application without arguments, you will get a REPL mode. + +### File interpretation + +If flag `-i ` is passed, a file will be interpreted. Additionally, you can provide `--liveness-optimization` flag +to enable liveness optimization and provide starting variables and its values. ## Static Analysis We wrote a static analyzer with liveness optimization that eliminate dead code. It could make code faster in situations -when we compute unused in future code. E.g.: TODO +when we compute unused in future code. E.g. in this code we have unnecessary infinity loop: + +```text +write 1 +def f() { x := 0; while 1 do { x := x + 1} } return 1 +def g() { x := f() } +g() +``` + +This will be optimized into + +```text +write 1 +def f() { x := 0; while 1 do { x := x + 1} } return 1 +def g() { } +g() +``` +That is in common not used for optimization, but used for error analysis and highlighting. diff --git a/src/Evaluate.hs b/src/Evaluate.hs index b53d2e1..60a5119 100644 --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -90,11 +90,13 @@ evaluateOneStatement (Let name value) = do evaluateOneStatement Skip = pure () -evaluateOneStatement (While expression statements) = do +evaluateOneStatement while@(While expression statements) = do value <- runMaybeT $ evaluateExpression expression case value of Just val - | toBool val -> evaluateStatements statements + | toBool val -> do + evaluateStatements statements + evaluateOneStatement while | otherwise -> pure () Nothing -> pure () diff --git a/src/Execute.hs b/src/Execute.hs index 5fa1f98..5640040 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -23,7 +23,7 @@ run' optimize strs = do parsed <- runMaybeT $ parse strs case parsed of Nothing -> pure () - Just sts -> foldr ((>>) . execute) (pure ()) (map optimizeLive sts ++ map (filter $ not . isFunctionDeclaration) sts) + Just sts -> if optimize then foldr ((>>) . execute) (pure ()) (map optimizeLive sts ++ map (filter $ not . isFunctionDeclaration) sts) else execute $ concat sts execute :: [Statement] -> StateT Context IO () From be7c4b0820537df6fa6348890d46d15b9cfbef2f Mon Sep 17 00:00:00 2001 From: khbminus Date: Sun, 1 Jan 2023 19:53:24 +0100 Subject: [PATCH 74/75] Fixed multiline bugs & added options to see IR & extended code --- app/Main.hs | 13 +++++++++---- src/Console.hs | 28 ++++++++++++++++++++++++++-- src/ConsoleParser.hs | 15 ++++++++++++++- src/Error.hs | 2 +- src/Execute.hs | 17 ++++++++++++++--- src/Grammar.hs | 4 ++-- 6 files changed, 66 insertions(+), 13 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 715c2e0..d306ae3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,7 @@ module Main where import Options.Applicative ( (<**>), fullDesc, header, info, progDesc, execParser, helper ) -import Console (runLoop, readEvalWriteLoop) +import Console (runLoop, readEvalWriteLoop, printIr, printExtended) import ConsoleParser (Action(..), Input(..), actionParser, getVarContext) import Context (Context(vars), newContext) import Control.Monad.State ( evalStateT ) @@ -20,12 +20,17 @@ main = do ) runAction :: Action -> IO () -runAction (Action (FileInput path) live varContext) = do +runAction (Action (FileInput path) live varContext extend ir) = do i <- readFile path let context = newContext { Context.vars = [getVarContext varContext]} - evalStateT (runLoop live $ lines i) context + case (ir, extend) of + (False, False) -> evalStateT (runLoop live [i]) context + (False, True) -> evalStateT (printExtended live [i]) context + (True, False) -> evalStateT (printIr live [i]) context + (True, True) -> evalStateT (do {printExtended live [i]; printIr live [i]}) context -- выход: q -runAction (Action Interactive _ varContext) = +runAction (Action Interactive _ varContext extend ir) = + if extend || ir then error "can't handle extend or IR option in REPL mode" else let context = newContext { Context.vars = [getVarContext varContext]} in evalStateT readEvalWriteLoop context diff --git a/src/Console.hs b/src/Console.hs index b2b68b8..f8a94f9 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -1,11 +1,17 @@ module Console where import Context (Context(..)) -import Execute (run', executeREPL) +import Execute (run', executeREPL, applyToCode) import System.IO ( hFlush, stdout ) import Control.Monad ( when ) -import Control.Monad.State ( MonadTrans(lift) ) +import Control.Monad.State ( MonadTrans(lift), StateT (StateT) ) import Control.Monad.Trans.State ( StateT, get, put ) +import Data.List (intercalate) +import Statement (Statement) +import Control.Monad (liftM) +import Compiler.Hoopl +import Analysis.AstToIr (astToIR) +import qualified Analysis.IR (Proc(..)) readEvalWriteLoop :: StateT Context IO () readEvalWriteLoop = do @@ -18,6 +24,24 @@ runLoop live input = do context <- get maybe (pure ()) (lift . print) (Context.error context) +printExtended :: Bool -> [String] -> StateT Context IO () +printExtended live input = do + extended <- applyToCode live input f "" + (lift . putStrLn) extended + where + f sts = intercalate ";\n" (map show sts) + +printIr :: Bool -> [String] -> StateT Context IO () +printIr live input = do + ir <- applyToCode live input f "" + (lift . putStrLn) ir + where + getIr sts = snd $ runSimpleUniqueMonad $ runWithFuel infiniteFuel (astToIR sts) + + prettyShow p = "IR for function " ++ Analysis.IR.name p ++ ":\n" ++ showGraph show (Analysis.IR.body p) + + f sts = intercalate "\n\n" (map prettyShow $ getIr sts) + unsetError :: StateT Context IO () unsetError = do context <- get diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs index 4eecf7b..d4af06a 100644 --- a/src/ConsoleParser.hs +++ b/src/ConsoleParser.hs @@ -11,12 +11,14 @@ data Action = Action { input :: Input , liveness :: Bool , vars :: [String] + , extend :: Bool + , ir :: Bool } deriving (Show) -- Парсер аргументов командной строки actionParser :: Optparse.Parser Action -actionParser = Action <$> (inputParser <|> pure Interactive)<*> liveOptParser <*> varsParser +actionParser = Action <$> (inputParser <|> pure Interactive) <*> liveOptParser <*> varsParser <*> extendParser <*> irParser -- Тип входных данных data Input = FileInput FilePath -- Имя входного файла @@ -37,6 +39,17 @@ liveOptParser = Optparse.switch ( Optparse.long "liveness-optimization" <> Optparse.help "Whether to enable liveness optimization" ) +extendParser :: Optparse.Parser Bool +extendParser = Optparse.switch + ( Optparse.long "extend" + <> Optparse.short 'E' + <> Optparse.help "Print instructions to execute, but do not execute code" ) + +irParser :: Optparse.Parser Bool +irParser = Optparse.switch + ( Optparse.long "ir" + <> Optparse.help "Print IR of code" ) + varsParser :: Optparse.Parser [String] varsParser = Optparse.many $ Optparse.argument Optparse.str $ Optparse.metavar "VARS..." diff --git a/src/Error.hs b/src/Error.hs index 4a4ff1a..1cfbb60 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -4,7 +4,7 @@ import Data.Void (Void) type ParsecError = ParseErrorBundle String Void -data RuntimeError = ParserError ParsecError +data RuntimeError = ParserError String | VarNotFound String | FunctionNotFound String | UnexpectedEOF diff --git a/src/Execute.hs b/src/Execute.hs index 5640040..8928ca5 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -1,4 +1,4 @@ -module Execute (run, run', execute, executeREPL) where +module Execute (run, run', execute, executeREPL, applyToCode) where import Context ( Context(..), setErrorT ) import Control.Monad.State @@ -10,6 +10,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Statement (Statement) import Analysis.Live (optimizeLive) import Analysis.AstToIr (isFunctionDeclaration) +import Text.Megaparsec (errorBundlePretty) run :: [String] -> StateT Context IO () run strs = do @@ -25,6 +26,16 @@ run' optimize strs = do Nothing -> pure () Just sts -> if optimize then foldr ((>>) . execute) (pure ()) (map optimizeLive sts ++ map (filter $ not . isFunctionDeclaration) sts) else execute $ concat sts +applyToCode :: Bool -> [String] -> ([Statement] -> a) -> a -> StateT Context IO a +applyToCode optimize strs f defaultValue = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> return defaultValue + Just sts -> do + let sts' = concat sts + let realSts = if optimize then optimizeLive sts' ++ filter (not . isFunctionDeclaration) sts' else sts' + return $ f realSts + execute :: [Statement] -> StateT Context IO () execute statements = do @@ -35,7 +46,7 @@ execute statements = do parse :: [String] -> MaybeT (StateT Context IO) [[Statement]] parse (x:xs) = do case parseStatement x of - Left err -> do { lift $ setErrorT $ ParserError err; mzero } + Left err -> do { lift $ setErrorT $ ParserError $ errorBundlePretty err; mzero } Right parsed -> do parsedTail <- parse xs return $ parsed : parsedTail @@ -46,7 +57,7 @@ executeREPL str = do context <- get guard ( isNothing (Context.error context) ) case parseStatementOrExpression str of - Left err -> setErrorT $ ParserError err + Left err -> setErrorT $ ParserError $ errorBundlePretty err Right (ConsoleStatement st) -> evaluateStatements st Right (ConsoleExpression ex) -> do res <- runMaybeT $ evaluateExpression ex diff --git a/src/Grammar.hs b/src/Grammar.hs index 4c4751e..654ae5e 100644 --- a/src/Grammar.hs +++ b/src/Grammar.hs @@ -132,7 +132,7 @@ functionDeclaration = buildDeclaration <$> (symbol "def" *> name) <*> parens (name `sepBy` symbol ",") - <*> curlyParens statement + <*> curlyParens (lexeme statement) <*> optional (symbol "return" *> expression) where buildDeclaration a b c d = [FunctionDeclaration a (Function b c d)] @@ -147,7 +147,7 @@ statement :: Parser [Statement] statement = concat <$> (terms `sepBy1` symbol ";") where terms = - choice + lexeme $ choice [ ifThenElse, while, write, From d7a17e61d80a3092b0dd9f4424e036039630fb8f Mon Sep 17 00:00:00 2001 From: khbminus Date: Mon, 2 Jan 2023 13:17:24 +0100 Subject: [PATCH 75/75] error output in & and test fixes --- app/Main.hs | 8 ++++---- src/Console.hs | 12 +++++++----- src/Execute.hs | 24 ++++++++++-------------- test/Test/Execute.hs | 3 ++- 4 files changed, 23 insertions(+), 24 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index d306ae3..f00eeee 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,10 +24,10 @@ runAction (Action (FileInput path) live varContext extend ir) = do i <- readFile path let context = newContext { Context.vars = [getVarContext varContext]} case (ir, extend) of - (False, False) -> evalStateT (runLoop live [i]) context - (False, True) -> evalStateT (printExtended live [i]) context - (True, False) -> evalStateT (printIr live [i]) context - (True, True) -> evalStateT (do {printExtended live [i]; printIr live [i]}) context + (False, False) -> evalStateT (runLoop live i) context + (False, True) -> evalStateT (printExtended live i) context + (True, False) -> evalStateT (printIr live i) context + (True, True) -> evalStateT (do {printExtended live i; printIr live i}) context -- выход: q runAction (Action Interactive _ varContext extend ir) = diff --git a/src/Console.hs b/src/Console.hs index f8a94f9..3cc158e 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -18,23 +18,25 @@ readEvalWriteLoop = do input <- lift $ prompt "L: " when (input /= "q") $ executeREPL input >> unsetError >> readEvalWriteLoop -runLoop :: Bool -> [String] -> StateT Context IO () +runLoop :: Bool -> String -> StateT Context IO () runLoop live input = do run' live input context <- get maybe (pure ()) (lift . print) (Context.error context) -printExtended :: Bool -> [String] -> StateT Context IO () +printExtended :: Bool -> String -> StateT Context IO () printExtended live input = do extended <- applyToCode live input f "" - (lift . putStrLn) extended + ctx <- get + (lift . putStrLn) $ maybe extended show (Context.error ctx) where f sts = intercalate ";\n" (map show sts) -printIr :: Bool -> [String] -> StateT Context IO () +printIr :: Bool -> String -> StateT Context IO () printIr live input = do ir <- applyToCode live input f "" - (lift . putStrLn) ir + ctx <- get + (lift . putStrLn) $ maybe ir show (Context.error ctx) where getIr sts = snd $ runSimpleUniqueMonad $ runWithFuel infiniteFuel (astToIR sts) diff --git a/src/Execute.hs b/src/Execute.hs index 8928ca5..ea21373 100644 --- a/src/Execute.hs +++ b/src/Execute.hs @@ -12,28 +12,27 @@ import Analysis.Live (optimizeLive) import Analysis.AstToIr (isFunctionDeclaration) import Text.Megaparsec (errorBundlePretty) -run :: [String] -> StateT Context IO () +run :: String -> StateT Context IO () run strs = do parsed <- runMaybeT $ parse strs case parsed of Nothing -> pure () - Just sts -> foldr ((>>) . execute) (pure ()) sts + Just sts -> execute sts -run' :: Bool -> [String] -> StateT Context IO () +run' :: Bool -> String -> StateT Context IO () run' optimize strs = do parsed <- runMaybeT $ parse strs case parsed of Nothing -> pure () - Just sts -> if optimize then foldr ((>>) . execute) (pure ()) (map optimizeLive sts ++ map (filter $ not . isFunctionDeclaration) sts) else execute $ concat sts + Just sts -> if optimize then execute (optimizeLive sts ++ filter (not . isFunctionDeclaration) sts) else execute $ sts -applyToCode :: Bool -> [String] -> ([Statement] -> a) -> a -> StateT Context IO a +applyToCode :: Bool -> String -> ([Statement] -> a) -> a -> StateT Context IO a applyToCode optimize strs f defaultValue = do parsed <- runMaybeT $ parse strs case parsed of Nothing -> return defaultValue Just sts -> do - let sts' = concat sts - let realSts = if optimize then optimizeLive sts' ++ filter (not . isFunctionDeclaration) sts' else sts' + let realSts = if optimize then optimizeLive sts ++ filter (not . isFunctionDeclaration) sts else sts return $ f realSts @@ -43,15 +42,12 @@ execute statements = do guard ( isNothing (Context.error context) ) evaluateStatements statements -parse :: [String] -> MaybeT (StateT Context IO) [[Statement]] -parse (x:xs) = do +parse :: String -> MaybeT (StateT Context IO) [Statement] +parse x = do case parseStatement x of Left err -> do { lift $ setErrorT $ ParserError $ errorBundlePretty err; mzero } - Right parsed -> do - parsedTail <- parse xs - return $ parsed : parsedTail -parse [] = return [] - + Right parsed -> + return parsed executeREPL :: String -> StateT Context IO () executeREPL str = do context <- get diff --git a/test/Test/Execute.hs b/test/Test/Execute.hs index c102d21..db5f93a 100644 --- a/test/Test/Execute.hs +++ b/test/Test/Execute.hs @@ -11,6 +11,7 @@ import Statement (Expression (..), Operations (..), Statement (..)) import Test.Tasty.HUnit (assertBool, Assertion, testCase) import Test.Tasty import Execute(run) +import Data.List (intercalate) checkOutput :: Context -> [String] -> Bool checkOutput cxt out = Context.output cxt == Buffer out @@ -73,7 +74,7 @@ unit_basicWhileTest = do unit_functions :: Assertion unit_functions = do - let code = + let code = intercalate ";\n" [ "def f() { write 1 } return 2", "f()",