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 2e805bf..dd63f2d 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 @@ -25,7 +25,19 @@ source-repository head library exposed-modules: - Lib + Analysis.AstToIr + Analysis.IR + Analysis.IrToAst + Analysis.Live + Analysis.OptSupport + Console + ConsoleParser + Context + Error + Evaluate + Execute + Grammar + Statement other-modules: Paths_L_static_analyzer hs-source-dirs: @@ -33,6 +45,14 @@ 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 + , hoopl + , megaparsec + , mtl + , optparse-applicative + , parser-combinators + , transformers default-language: Haskell2010 executable L-static-analyzer-exe @@ -45,17 +65,50 @@ executable L-static-analyzer-exe build-depends: L-static-analyzer , base >=4.7 && <5 + , composition-prelude + , containers + , hoopl + , megaparsec + , mtl + , optparse-applicative + , parser-combinators + , transformers 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.ConsoleParser + Test.Evaluate + Test.Execute + Test.Live + Test.Parsers + Test.PropertyExpr + Test.PropertyOptimizing 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 + , composition-prelude + , containers + , hedgehog + , hoopl + , hspec + , hspec-megaparsec + , megaparsec + , mtl + , parser-combinators + , tasty + , tasty-discover + , tasty-hedgehog + , tasty-hspec + , tasty-hunit + , tasty-quickcheck + , transformers default-language: Haskell2010 diff --git a/README.md b/README.md index ebc4c26..59212e2 100644 --- a/README.md +++ b/README.md @@ -1 +1,89 @@ -# 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 + +### 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. 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/app/Main.hs b/app/Main.hs index 4c6b30f..f00eeee 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,36 @@ -module Main (main) where +module Main where -import Lib +import Options.Applicative ( (<**>), fullDesc, header, info, progDesc, execParser, helper ) +import Console (runLoop, readEvalWriteLoop, printIr, printExtended) +import ConsoleParser (Action(..), Input(..), actionParser, getVarContext) +import Context (Context(vars), newContext) +import Control.Monad.State ( evalStateT ) +-- Программа парсит аргументы командной строки при помощи execParser, +-- а потом запускает функцию runAction (логику приложения) main :: IO () -main = someFunc +main = do + runAction =<< execParser opts + where + -- Задает парсер аргументов actionParser, сопровождая его автоматической генерацией странички help. + opts = info (actionParser <**> helper) + ( fullDesc + <> progDesc "This application executes programms in L" + <> header "L interpreter" + ) + +runAction :: Action -> IO () +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 + +-- выход: q +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/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/package.yaml b/package.yaml index 0da5b74..bdce406 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,13 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- containers +- transformers +- composition-prelude +- megaparsec +- parser-combinators +- mtl +- hoopl ghc-options: - -Wall @@ -35,6 +42,11 @@ ghc-options: library: source-dirs: src + dependencies: + - containers + - optparse-applicative + - transformers + - megaparsec executables: L-static-analyzer-exe: @@ -46,14 +58,30 @@ executables: - -with-rtsopts=-N dependencies: - L-static-analyzer + - optparse-applicative 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-hspec + - tasty-hedgehog + - tasty-hunit + - tasty-discover + - tasty-quickcheck - L-static-analyzer + - HUnit + - tasty-hunit + - tasty + - transformers diff --git a/src/Analysis/AstToIr.hs b/src/Analysis/AstToIr.hs new file mode 100644 index 0000000..86c50f8 --- /dev/null +++ b/src/Analysis/AstToIr.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} +module Analysis.AstToIr(astToIR, LabelMap, isFunctionDeclaration) where + +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 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 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] -> Maybe A.Expression -> LabelMapM (Label, Graph I.Instruction C C) +toBody body retExpr = do + let blocks = splitIntoBlocks body + (lastLabel, lastGraph) <- lastBlock retExpr + (fullLabel, fullGraph) <- fullBlockTransform blocks lastLabel + return (fullLabel, fullGraph |*><*| lastGraph) + +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 retExpr)) + +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@(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) +blockTransform (code, last) next = do + 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 -> 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 + (realNextLabel, nextGraph) <- fullBlockTransform xs next + (nowLabel, nowGraph) <- blockTransform x realNextLabel + return (nowLabel, nowGraph |*><*| nextGraph) + +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 + 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 <- newLabel + (sLabel, sGraph) <- fullBlockTransform blocks whileLabel + 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" + + +toMid :: A.Statement -> I.Instruction O O +toMid (A.Let v e) = I.Let v e +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" + +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' + ) + +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 new file mode 100644 index 0000000..e3ff840 --- /dev/null +++ b/src/Analysis/IR.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} + +module Analysis.IR(Instruction(..), Proc(..), M) 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 + 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 + +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] + successors (Return _) = [] + 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 + 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 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/IrToAst.hs b/src/Analysis/IrToAst.hs new file mode 100644 index 0000000..6791635 --- /dev/null +++ b/src/Analysis/IrToAst.hs @@ -0,0 +1,138 @@ +{-# 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' + +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 + 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 $ 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/Analysis/Live.hs b/src/Analysis/Live.hs new file mode 100644 index 0000000..f7e7608 --- /dev/null +++ b/src/Analysis/Live.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +module Analysis.Live where + +import Data.Maybe +import qualified Data.Set as S + +import Compiler.Hoopl +import Analysis.IR +import Analysis.OptSupport +import Statement (Expression(VariableName), Statement) +import Analysis.AstToIr (astToIR) +import Analysis.IrToAst (irToAst) + +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 + +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/Analysis/OptSupport.hs b/src/Analysis/OptSupport.hs new file mode 100644 index 0000000..62f2a7d --- /dev/null +++ b/src/Analysis/OptSupport.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} +{-# LANGUAGE GADTs #-} +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 (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 diff --git a/src/Console.hs b/src/Console.hs new file mode 100644 index 0000000..3cc158e --- /dev/null +++ b/src/Console.hs @@ -0,0 +1,57 @@ +module Console where + +import Context (Context(..)) +import Execute (run', executeREPL, applyToCode) +import System.IO ( hFlush, stdout ) +import Control.Monad ( when ) +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 + input <- lift $ prompt "L: " + when (input /= "q") $ executeREPL input >> unsetError >> readEvalWriteLoop + +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 live input = do + extended <- applyToCode live input f "" + 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 live input = do + ir <- applyToCode live input f "" + ctx <- get + (lift . putStrLn) $ maybe ir show (Context.error ctx) + 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 + let f err = lift (print err) >> put (context { Context.error = Nothing }) + maybe (pure ()) f (Context.error context) + +prompt :: String -> IO String +prompt text = do + putStr text + hFlush stdout + getLine diff --git a/src/ConsoleParser.hs b/src/ConsoleParser.hs new file mode 100644 index 0000000..d4af06a --- /dev/null +++ b/src/ConsoleParser.hs @@ -0,0 +1,68 @@ +module ConsoleParser where + +import qualified Options.Applicative as Optparse +import qualified Text.Megaparsec as Megaparsec +import qualified Grammar as LParser +import Text.Megaparsec ( (), (<|>) ) +import Context (VarContext, setVarContext, emptyVarContext) + +-- Тип данных, агрегирующий все аргументы командной строки, возвращается actionParser-ом +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 <*> extendParser <*> irParser + +-- Тип входных данных +data Input = FileInput FilePath -- Имя входного файла + | Interactive + deriving (Show) + +-- Парсер аргумента, специфицирующий, откуда брать входные данные +-- Флаг -i/--input позволяет задать строку -- имя входного файла +inputParser :: Optparse.Parser Input +inputParser = FileInput <$> Optparse.strOption + ( Optparse.short 'i' -- короткое имя флага (-i) + <> Optparse.long "input" -- длинное имя флага (--input) + <> 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" ) + +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..." + +varArgParser :: LParser.Parser (String, Int) +varArgParser = (,) + <$> (LParser.lexeme LParser.name "Variable name") + <*> (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 var val (getVarContext xs) +getVarContext [] = emptyVarContext + diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 index 0000000..ac0b785 --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} + +module Context where + +import qualified Data.Map as Map +import Error (RuntimeError (FunctionNotFound, VarNotFound)) +import Statement (Function (..)) +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) + +newtype VarContext = VarContext {varContext :: Map.Map String Int} deriving (Show, Eq) + +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} + +emptyFunContext :: FunContext +emptyFunContext = FunContext {funContext = Map.empty} + +setVarContext :: String -> Int -> VarContext -> VarContext +setVarContext name val ctx = + let mp = varContext ctx in + VarContext $ Map.insert name val mp + +data Context = Context + { funs :: [FunContext], + vars :: [VarContext], + error :: Maybe RuntimeError, + input :: Buffer, + output :: Buffer, + flushEnabled :: Bool + } + deriving (Show) + +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 + +newContext :: Context +newContext = + Context + { funs = [emptyFunContext], + vars = [emptyVarContext], + Context.error = Nothing, + input = Buffer [], + output = Buffer [], + flushEnabled = True + } + +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)) + +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 + in let vc = VarContext $ Map.insert name val mp + in ctx {vars = vc : (tail . vars) ctx} + +getFun :: String -> Context -> Maybe Function +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 = get >>= put . setError err + +pushOutput :: String -> StateT Context IO () +pushOutput str = do + cxt <- get + 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 + +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 = + let mp = funContext . head . funs $ ctx + in let fc = FunContext $ Map.insert name f mp + in ctx {funs = fc : (tail . funs) 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} + +flush :: StateT Context IO () +flush = do + + out <- runMaybeT popOutput + when (isJust out) $ do + lift $ putStrLn $ fromJust out + flush diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 0000000..1cfbb60 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,15 @@ +module Error where +import Text.Megaparsec.Error (ParseErrorBundle) +import Data.Void (Void) + +type ParsecError = ParseErrorBundle String Void + +data RuntimeError = ParserError String + | VarNotFound String + | FunctionNotFound String + | UnexpectedEOF + | 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 new file mode 100644 index 0000000..60a5119 --- /dev/null +++ b/src/Evaluate.hs @@ -0,0 +1,146 @@ +module Evaluate (evaluateStatements, evaluateOneStatement, evaluateExpression, evaluateList) where + +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 (..)) +import Text.Read (readMaybe) +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Data.Maybe (isNothing, fromJust, isJust) +import Error (RuntimeError(InvalidInput, UnexpectedEOF, DivisionByZero)) +import GHC.IO.Handle (hIsOpen) +import GHC.IO.Handle.FD (stdin) + +evaluateList :: [Expression] -> MaybeT (StateT Context IO) [Int] +evaluateList [] = return [] +evaluateList (x : xs) = do + x' <- evaluateExpression x + xs' <- evaluateList xs + return $ x' : xs' + + +evaluateExpression :: Expression -> MaybeT (StateT Context IO) Int +evaluateExpression (Const x) = return x +evaluateExpression (VariableName name) = getVarT name + +evaluateExpression (FunctionCall name argumentValues) = do + 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 x y) = do + x' <- evaluateExpression x + y' <- evaluateExpression 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 -> 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 + + 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' <- runMaybeT $ evaluateExpression value + case value' of + Just val -> modify (setVar name val) + Nothing -> pure () + +evaluateOneStatement Skip = pure () + +evaluateOneStatement while@(While expression statements) = do + value <- runMaybeT $ evaluateExpression expression + case value of + Just val + | toBool val -> do + evaluateStatements statements + evaluateOneStatement while + | otherwise -> pure () + Nothing -> pure () + +evaluateOneStatement (If expression trueStatements falseStatements) = do + value <- runMaybeT $ evaluateExpression expression + case value of + Just val + | 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 -> pushOutput $ show val + Nothing -> pure () + +evaluateOneStatement (Read var) = do + 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 + +evaluateStatements :: [Statement] -> StateT Context IO () +evaluateStatements [] = pure () +evaluateStatements (x : xs) = do + evaluateOneStatement x + cxt <- get + when (flushEnabled cxt) flush + evaluateStatements xs diff --git a/src/Execute.hs b/src/Execute.hs new file mode 100644 index 0000000..ea21373 --- /dev/null +++ b/src/Execute.hs @@ -0,0 +1,62 @@ +module Execute (run, run', execute, executeREPL, applyToCode) where + +import Context ( Context(..), setErrorT ) +import Control.Monad.State +import Error (RuntimeError (..)) +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) +import Text.Megaparsec (errorBundlePretty) + +run :: String -> StateT Context IO () +run strs = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> pure () + Just sts -> execute sts + +run' :: Bool -> String -> StateT Context IO () +run' optimize strs = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> pure () + 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 optimize strs f defaultValue = do + parsed <- runMaybeT $ parse strs + case parsed of + Nothing -> return defaultValue + Just sts -> do + let realSts = if optimize then optimizeLive sts ++ filter (not . isFunctionDeclaration) sts else sts + return $ f realSts + + +execute :: [Statement] -> StateT Context IO () +execute statements = do + context <- get + guard ( isNothing (Context.error context) ) + evaluateStatements statements + +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 -> + return parsed +executeREPL :: String -> StateT Context IO () +executeREPL str = do + context <- get + guard ( isNothing (Context.error context) ) + case parseStatementOrExpression str of + Left err -> setErrorT $ ParserError $ errorBundlePretty 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 new file mode 100644 index 0000000..654ae5e --- /dev/null +++ b/src/Grammar.hs @@ -0,0 +1,172 @@ +module Grammar where + +import Control.Monad +import Control.Monad.Combinators.Expr +import Data.Void +import Statement (Expression (..), Function (..), Operations (..), Statement (..), reservedKeywords) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Error (ParsecError) + +type Parser = Parsec Void String + +sc :: Parser () +sc = L.space (void spaceChar) empty empty + +lexeme :: Parser a -> Parser a +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" + +name :: Parser String +name = (lexeme . try) (p >>= check) + where + p = (:) <$> letterChar <*> many alphaNumChar "Variable" + 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 + +varName :: Parser Expression +varName = VariableName <$> name + +funCall :: Parser Expression +funCall = do + FunctionCall <$> (lexeme name "Function name") <*> (lexeme . parens) (arguments "arguments") + where + arguments :: Parser [Expression] + arguments = expression `sepBy` lexeme (symbol ",") + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +curlyParens :: Parser a -> Parser a +curlyParens = between (symbol "{") (symbol "}") + +expressionTerm :: Parser Expression +expressionTerm = + choice + [ parens expression, + try funCall, + varName, + constValue + ] + +expressionOperationsTable :: [[Operator Parser Expression]] +expressionOperationsTable = + [ [ binary "*" $ Application Multiplication, + binary "/" $ Application Division, + binary "%" $ Application Modulo + ], + [ binary "+" $ Application Addition, + binary "-" $ Application Subtraction + ], + [ binary "==" $ Application Equals, + binary "!=" $ Application NotEquals, + binary "<" $ Application Less, + binary "<=" $ Application LessOrEquals, + binary ">=" $ Application GreaterOrEquals, + binary ">" $ Application Greater + ], + [ binary "&&" $ Application LazyAnd + ], + [ binary "||" $ Application LazyOr + ] + ] + where + binary :: String -> (Expression -> Expression -> Expression) -> Operator Parser Expression + binary name f = InfixL (f <$ symbol name) + +expression :: Parser Expression +expression = makeExprParser expressionTerm expressionOperationsTable + +singleton :: a -> [a] +singleton x = [x] + +letVariable :: Parser [Statement] +letVariable = singleton <$> (Let <$> (lexeme name "Variable name") <*> (symbol ":=" *> expression) "Variable let") + +write :: Parser [Statement] +write = singleton . Write <$> (symbol "write" *> expression) "write statement" + +readVariable :: Parser [Statement] +readVariable = singleton . Read <$> (symbol "read" *> name "Read statement") + +while :: Parser [Statement] +while = + singleton + <$> ( While + <$> (between (symbol "while") (symbol "do") expression "While condition") + <*> (curlyParens statement "While statement") + ) + +ifThenElse :: Parser [Statement] +ifThenElse = + singleton + <$> ( If + <$> (symbol "if" *> expression "If condition") + <*> (symbol "then" *> curlyParens statement "True statement") + <*> (symbol "else" *> curlyParens statement "False Statement") + ) + +funCallStatement :: Parser [Statement] +funCallStatement = + singleton + <$> ( FunctionCallStatement + <$> (lexeme name "Function name") + <*> (lexeme . parens) (arguments "arguments") + ) + where + arguments :: Parser [Expression] + arguments = expression `sepBy` lexeme (symbol ",") + +functionDeclaration :: Parser [Statement] +functionDeclaration = + buildDeclaration + <$> (symbol "def" *> name) + <*> parens (name `sepBy` symbol ",") + <*> curlyParens (lexeme statement) + <*> optional (symbol "return" *> expression) + where + buildDeclaration a b c d = [FunctionDeclaration a (Function b c d)] + +skip :: Parser [Statement] +skip = [Skip] <$ symbol "skip" + +split :: Parser [Statement] +split = concat <$> (statement `sepBy1` symbol ";") + +statement :: Parser [Statement] +statement = concat <$> (terms `sepBy1` symbol ";") + where + terms = + lexeme $ choice + [ ifThenElse, + while, + write, + readVariable, + skip, + try funCallStatement, + functionDeclaration, + 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/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/src/Statement.hs b/src/Statement.hs new file mode 100644 index 0000000..e9a1171 --- /dev/null +++ b/src/Statement.hs @@ -0,0 +1,90 @@ +module Statement where + +data Operations + = 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 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 + | FunctionCallStatement String [Expression] + | FunctionDeclaration String Function + | Write Expression + | Read String + | While Expression [Statement] + | If Expression [Statement] [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 ++ ") " ++ 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) + +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 + +reservedKeywords :: [String] +reservedKeywords = ["if", "then", "else", "while", "do", "read", "write"] \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 29293f3..e905565 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,10 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +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: {} 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..22a9bd3 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,20 @@ +import Test.Tasty + +import qualified Test.PropertyExpr +import qualified Test.Parsers +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" + [ 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 + , 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/ConsoleParser.hs b/test/Test/ConsoleParser.hs new file mode 100644 index 0000000..ae372ba --- /dev/null +++ b/test/Test/ConsoleParser.hs @@ -0,0 +1,45 @@ +module Test.ConsoleParser where + +import Grammar (Parser) +import ConsoleParser (varArgParser, getVarContext) +import Test.Tasty.HUnit +import Test.Tasty +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 + 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_varArgParser :: IO () +unit_varArgParser = do + let success = parseSuccessful varArgParser + let failure = parseFailed varArgParser + + assertBool "1" $ success "x=10" ("x", 10) + assertBool "3" $ success "x=0" ("x", 0) + + 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 { varContext = Map.fromList cxt } + +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 new file mode 100644 index 0000000..335eb75 --- /dev/null +++ b/test/Test/Evaluate.hs @@ -0,0 +1,27 @@ +module Test.Evaluate where + +import Evaluate (evaluateList) +import Context (newContext) +import Test.Tasty.HUnit +import Test.Tasty +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 + +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 new file mode 100644 index 0000000..db5f93a --- /dev/null +++ b/test/Test/Execute.hs @@ -0,0 +1,116 @@ +module Test.Execute where + +import Context (Buffer (..), Context (..), VarContext (..), newContext) +import Control.Monad.State (execStateT) +import qualified Data.Map as Map +import Error (RuntimeError (..)) +import Evaluate (evaluateStatements) +import GHC.IO.Handle (hClose) +import GHC.IO.Handle.FD (stdin) +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 + +checkError :: Context -> RuntimeError -> Bool +checkError cxt err = Context.error cxt == Just err + +noFlushContext :: Context +noFlushContext = newContext {flushEnabled = False} + +unit_executeWrite :: Assertion +unit_executeWrite = do + let writeConst = Write (Const 1) + let writeVar = Write (VariableName "var") + let contextWithVar = noFlushContext {vars = [VarContext (Map.fromList [("var", 123)])]} + + hClose stdin + + 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]) noFlushContext + assertBool "write var failure" $ checkOutput exitContext [] + assertBool "write var failure" $ checkError exitContext (VarNotFound "var") + +unit_executeRead :: Assertion +unit_executeRead = do + 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"] + + exitContext <- execStateT (evaluateStatements [readVar]) noFlushContext + assertBool "read var failure: end of input" $ checkError exitContext UnexpectedEOF + +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 = + [ 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 []} + + hClose stdin + exitContext <- execStateT (evaluateStatements code) context + assertBool "test successfull" $ checkOutput exitContext ["11", "1", "0"] + +unit_functions :: Assertion +unit_functions = do + let code = intercalate ";\n" + [ + "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" + ] + +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/Live.hs b/test/Test/Live.hs new file mode 100644 index 0000000..0f39239 --- /dev/null +++ b/test/Test/Live.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Test.Live where + +import Statement (Statement (..), Function (Function), Expression (..), Operations (Equals, Addition)) +import Grammar (parseStatement) +import Data.Either (isLeft, fromRight) +import Data.Maybe (fromJust) +import Analysis.Live (optimizeLive) + +import Test.Tasty.HUnit (assertEqual, Assertion, testCase) +import Test.Tasty + + +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 b a = b ++ fromRight [] a + +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) + +unit_Liveness :: Assertion +unit_Liveness = do + 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" (optimizeFromString testCode1) expected1 + assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 + assertEqual "Liveness 3" (optimizeFromString testCode3) expected3 + +unit_ReadWrite :: Assertion +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" (optimizeFromString testCode1) expected1 + assertEqual "Liveness 2" (optimizeFromString testCode2) expected2 + +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"))] + + 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" (optimizeFromString testCode1) expected1 + assertEqual "unchanged" (optimizeFromString 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 "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/Parsers.hs b/test/Test/Parsers.hs new file mode 100644 index 0000000..fe669ce --- /dev/null +++ b/test/Test/Parsers.hs @@ -0,0 +1,254 @@ +module Test.Parsers where + +import Grammar +import Statement +import Test.Tasty +import Test.Tasty.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 :: Assertion +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 :: Assertion +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 :: Assertion +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 :: Assertion +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 }" + + 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 :: Assertion +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 :: Assertion +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 :: Assertion +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" + ] + ] + +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 + +unit_functionsDeclarations :: Assertion +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 "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")))] + + + +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..ba6320d --- /dev/null +++ b/test/Test/PropertyExpr.hs @@ -0,0 +1,69 @@ +{-# 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 -> [String] -> Gen Expression +genExpr n vars = + Gen.recursive + Gen.choice + nonRecGens + [ + binOpGen + ] + where + binOpGen = do + op <- genOp + Gen.subterm2 (genExpr n vars) (genExpr n vars) (Application op) + numGen = Const <$> Gen.int (Range.constant 1 n) + varGen = VariableName <$> Gen.element vars + + nonRecGens = numGen : ([varGen | not (null vars)]) + + +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 diff --git a/test/Test/PropertyOptimizing.hs b/test/Test/PropertyOptimizing.hs new file mode 100644 index 0000000..1f58589 --- /dev/null +++ b/test/Test/PropertyOptimizing.hs @@ -0,0 +1,147 @@ +{-# 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 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) +import Data.Maybe + +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, _) <- 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) + +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 + +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 + +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 _ -> 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 = 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 + 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 = 100 + + calls <- forAll $ genFunCalls funParams callsAmount limVar + + ctx1'' <- liftIO $ execStateT (execute calls) ctx1' + ctx2'' <- liftIO $ execStateT (execute calls) ctx2' + isError ctx1'' ctx2'' + + +props :: [TestTree] +props = + [ testProperty "Test correctness of liveness optimization" prop_is_eval_ok ] \ No newline at end of file