Merge branch 'feature/bnf' of github.com:AxelHumeau/LobsterLang into …

…feature/bnf

.github/workflows/Deploy.yml

@@ -38,14 +38,12 @@ jobs:
         uses: haskell-actions/setup@v2
         with:
           enable-stack: true
-      - name: Install documentation
-        run: sudo apt-get install haskell-platform-doc && sudo apt-get install ghc-doc
       - name: Create documentation
-        run: haddock -ohtml --html LobsterLang/src/*
+        run: stack haddock --haddock-arguments "-ohtml"
       - name: Deploy to GitHub Pages
         uses: crazy-max/ghaction-github-pages@v4
         with:
           target_branch: gh-pages
-          build_dir: html
+          build_dir: LobsterLang/html
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

LobsterLang/LobsterLang.cabal

@@ -5,9 +5,9 @@ cabal-version: 2.2
 -- see: https://github.com/sol/hpack
 
 name:           LobsterLang
-version:        0.1.0.0
-description:    Please see the README on GitHub at <https://github.com/githubuser/LobsterLang#readme>
-homepage:       https://github.com/githubuser/LobsterLang#readme
+version:        1.0
+description:    Please see the README on GitHub at <https://github.com/AxelHumeau/LobsterLang/blob/main/README.md>
+homepage:       https://github.com/AxelHumeau/LobsterLang
 bug-reports:    https://github.com/githubuser/LobsterLang/issues
 author:         Author name here
 maintainer:     [email protected]
@@ -73,6 +73,7 @@ test-suite LobsterLang-test
       AstEvalSpec
       AstOptimizerSpec
       CompilerSpec
+      ParserSpec
       VmSpec
       Paths_LobsterLang
   autogen-modules:

LobsterLang/app/Main.hs

@@ -13,14 +13,20 @@ import System.IO (isEOF)
 import System.Exit (exitWith, ExitCode (ExitFailure))
 import System.Environment (getArgs)
 import qualified AstEval
+import qualified AstOptimizer
+import qualified Compiler
 import Control.Exception
 import qualified AST
--- import Compiler
+import AstOptimizer (optimizeAst)
+
+
+lobsterNotHappy :: String -> String -> String -> String
+lobsterNotHappy color state str = "\ESC[" ++ color ++ "m\ESC[1mThe lobster is " ++ state ++ ": " ++ str ++ "\ESC[0m"
 
 -- | Return a Result that contain the evaluation of our Lisp String
 -- Takes as parameter the string that need to be evaluated and the Stack (Environment)
-interpretateLisp :: AST.Ast -> [Scope.ScopeMb] -> Either String (Maybe AST.Ast, [Scope.ScopeMb])
-interpretateLisp value stack = case AstEval.evalAst stack value of
+interpretateLobster :: AST.Ast -> [Scope.ScopeMb] -> Either String (Maybe AST.Ast, [Scope.ScopeMb])
+interpretateLobster value stack = case AstEval.evalAst stack value of
         (Left err, _) -> Left err
         (Right res', stack') -> Right (res', stack')
 
@@ -29,40 +35,43 @@ inputLoop :: [Scope.ScopeMb] -> IO ()
 -- inputLoop = print
 inputLoop stack = isEOF >>= \end -> if end then print "End of Interpretation GLaDOS" else
     getLine >>= \line -> case runParser parseLobster (0, 0) line of
-        Left err -> putStrLn ("\ESC[34m\ESC[1mThe lobster is angry: " ++ err ++ "\ESC[0m") >> inputLoop stack
+        Left err -> putStrLn (lobsterNotHappy "34" "angry" err) >> inputLoop stack
         Right (res, [], _) -> interpretateInfo res stack
-        Right (_, _, pos) -> putStrLn ("\ESC[34m\ESC[1mThe lobster is angry: " ++ errorParsing pos ++ "\ESC[0m") >> inputLoop stack
+        Right (_, _, pos) -> putStrLn (lobsterNotHappy "31" "angry" (errorParsing pos)) >> inputLoop stack
 
 interpretateInfo :: [AST.Ast] -> [Scope.ScopeMb] -> IO ()
 interpretateInfo [] stack = inputLoop stack
-interpretateInfo (x:xs) stack = case interpretateLisp x stack of
-    Left err -> putStrLn ("\ESC[31m\ESC[1mThe lobster is angry: " ++ err ++ "\ESC[0m") >> inputLoop stack
+interpretateInfo (x:xs) stack = case interpretateLobster x stack of
+    Left err -> putStrLn (lobsterNotHappy "31" "angry" err) >> inputLoop stack
     Right (res, stack') -> case res of
         Nothing -> interpretateInfo xs stack'
         Just value -> print value >> interpretateInfo xs stack'
 
-compileInfo :: [AST.Ast] -> [Scope.ScopeMb] -> IO ()
-compileInfo [] _ = putStr ""
-compileInfo (x:xs) stack = case interpretateLisp x stack of
-    Left err -> putStrLn ("\ESC[31m\ESC[1mThe lobster is angry: " ++ err ++ "\ESC[0m") >> exitWith (ExitFailure 84)
-    Right (res, stack') -> case res of
-        Nothing -> compileInfo xs stack'
-        Just value -> print value >> compileInfo xs stack'
+checkCompileInfo :: [Either AstOptimizer.AstError AstOptimizer.AstOptimised] -> [Either AstOptimizer.AstError AstOptimizer.AstOptimised] -> IO [Either AstOptimizer.AstError AstOptimizer.AstOptimised]
+checkCompileInfo [] list = return list
+checkCompileInfo (x:xs) list = case x of
+    Left (AstOptimizer.Error err ast) -> putStrLn (lobsterNotHappy "31" "angry" (err ++ " caused by: " ++ show ast)) >> checkCompileInfo xs (list ++ [x])
+    Right (AstOptimizer.Result _) -> checkCompileInfo xs (list ++ [x])
+    Right (AstOptimizer.Warning warning ast) -> putStrLn (lobsterNotHappy "33" "worried" (warning ++ " optimize to" ++ show ast)) >> checkCompileInfo xs (list ++ [x])
 
-compileFile :: String -> IO ()
-compileFile s = case runParser parseLobster (0, 0) s of
-        Left err -> print err >> exitWith (ExitFailure 84)
-        Right (res, [], _) -> print res >> compileInfo res []
-        Right (_, _, (row, col)) -> print ("Error on parsing on '" ++ show row ++ "' '" ++ show col)
-        -- (Right (Just res), stack') -> let instructions = (astToInstructions (AST.Cond (Boolean True) (Value 1) (Just (AST.Call "CallHere" [(Value 0)])))) in showInstructions instructions >> writeCompiledInstructionsToFile "output" (compileInstructions instructions)
+compileInfo :: String -> [AST.Ast] -> [Scope.ScopeMb] -> IO ()
+compileInfo _ [] _ = putStr ""
+compileInfo filename list stack = checkCompileInfo (optimizeAst stack list False) [] >>= \res -> case sequence res of
+        Left _ -> exitWith (ExitFailure 84)
+        Right value -> Compiler.compile (map AstOptimizer.fromOptimised value) (filename ++ ".o") True
 
+compileFile :: String -> String -> IO ()
+compileFile file s = case runParser parseLobster (0, 0) s of
+        Left err -> print err >> exitWith (ExitFailure 84)
+        Right (res, [], _) -> compileInfo file res []
+        Right (_, _, pos) -> putStrLn (lobsterNotHappy "34" "angry" (errorParsing pos))
 
 checkArgs :: [String] -> IO ()
 checkArgs [] = print "Launch Interpreter" >> inputLoop []
 checkArgs (file:_) = either
                         (\_ -> print "File doesn't exist" >> exitWith (ExitFailure 84))
-                        compileFile
-                    =<< (try (readFile file) :: IO (Either SomeException String))
+                        (compileFile file)
+                        =<< (try (readFile file) :: IO (Either SomeException String))
 
 -- | Main
 main :: IO ()

LobsterLang/src/AstOptimizer.hs

@@ -7,6 +7,7 @@
 
 module AstOptimizer
   ( optimizeAst,
+    fromOptimised,
     AstError (..),
     AstOptimised (..),
   )
@@ -55,7 +56,14 @@ optimizeAst stack ((Define n ast) : xs) inFunc = case optimizeAst stack [ast] in
       | inFunc -> Right (Result (Define n opAst)) : optimizeAst stack xs inFunc
       | otherwise -> Left (Error ('S' : 'y' : 'm' : 'b' : 'o' : 'l' : ' ' : '\'' : xs') (Define n opAst)) : optimizeAst stack xs inFunc
     (Left err, _) -> Left (Error err (Define n opAst)) : optimizeAst stack xs inFunc
-  [Right (Warning mes opAst)] -> Right (Warning mes (Define n opAst)) : optimizeAst stack xs inFunc
+  [Right (Warning mes opAst)] -> case evalAst stack (Define n opAst) of
+    (Right _, stack') -> Right (Warning mes (Define n opAst)) : optimizeAst stack' xs inFunc
+    (Left ('R' : 'e' : 'c' : 'u' : 'r' : 's' : 'i' : 'o' : 'n' : _), stack')  ->
+        Right (Warning "Possible infinite recursion" (Define n opAst)) : optimizeAst stack' xs inFunc
+    (Left ('S' : 'y' : 'm' : 'b' : 'o' : 'l' : ' ' : '\'' : xs'), _)
+      | inFunc -> Right (Result (Define n opAst)) : optimizeAst stack xs inFunc
+      | otherwise -> Left (Error ('S' : 'y' : 'm' : 'b' : 'o' : 'l' : ' ' : '\'' : xs') (Define n opAst)) : optimizeAst stack xs inFunc
+    (Left err, _) -> Left (Error err (Define n opAst)) : optimizeAst stack xs inFunc
   _ -> shouldntHappen stack (Define n ast : xs) inFunc
 optimizeAst stack ((Symbol s Nothing) : xs) inFunc
   | inFunc = Right (Result (Symbol s Nothing)) : optimizeAst stack xs inFunc

LobsterLang/src/Parse.hs

@@ -39,7 +39,10 @@ module Parse (
     errorParsing,
     parseDefineFn,
     parseLambda,
-    parseCond
+    parseCond,
+    parseFunctionValue,
+    parseBracket,
+    parseComment
 ) where
 
 import qualified AST
@@ -422,7 +425,7 @@ parseComment :: Parser Char
 parseComment = parseChar '#' *> Parser f
     where
         f :: Position -> String -> Either String (Char, String, Position)
-        f (row, col) ('\n':xs)  = Right ('\n', xs, (row + 1, col))
+        f (row, _) ('\n':xs)  = Right ('\n', xs, (row + 1, 0))
         f (row, col) "" = Right ('\n', "", (row, col + 1))
         f (row, col) (_:xs) = f (row, col + 1) xs
 

LobsterLang/src/Vm.hs

@@ -187,7 +187,7 @@ type Stack = [Value]
 type Inst = [Instruction]
 type Arg = [Value]
 type Func = [Instruction]
-type Env = [(String, Value)]
+type Env = [(String, Value, Int)]
 
 makeOperation :: Operator -> Stack -> Either String Stack
 makeOperation Add stack = case Stack.pop stack of
@@ -326,89 +326,102 @@ isBoolVal :: Maybe Value -> Bool
 isBoolVal (Just (BoolVal _)) = True
 isBoolVal _ = False
 
-isInEnv :: String -> Env -> Maybe Value
-isInEnv _ [] = Nothing
-isInEnv s (xs:as)
-    | fst xs == s = Just (snd xs)
-    | fst xs /= s = isInEnv s as
-isInEnv _ _ = Nothing
+isInEnv :: String -> Int -> Env -> Maybe Value
+isInEnv _ _ [] = Nothing
+isInEnv s d ((name, val, depth):as)
+    | name == s && (depth == 0 || depth == d) = Just val
+    | otherwise = isInEnv s d as
+
+updateInEnv :: String -> Int -> Value -> Env -> Env
+updateInEnv _ _ _ [] = []
+updateInEnv s d nv ((name, val, depth):as)
+    | name == s && (depth == 0 || depth == d) = (name, nv, depth) : as
+    | otherwise = (name, val, depth) : updateInEnv s d nv as
+
+clearUntilDepth :: Env -> Int -> Env
+clearUntilDepth [] _ = []
+clearUntilDepth ((name, val, depth):as) d
+    | depth > d = clearUntilDepth as d
+    | otherwise = (name, val, depth):as
 
 createList :: Int -> Stack -> [Value] -> (Stack, [Value])
 createList 0 stack val = (stack, val)
 createList n stack val = case Stack.pop stack of
     (Nothing, _) -> (stack, val)
     (Just x, stack1) -> createList (n - 1) stack1 (val ++ [x])
 
-exec :: Env -> Arg -> Inst -> Stack -> Either String Value
-exec _ _ (Call : _) [] = Left "Error: stack is empty"
-exec env arg (Call : xs) stack = case Stack.pop stack of
-        (Nothing, _) -> Left "Error: stack is empty"
+exec :: Int -> Env -> Arg -> Inst -> Stack -> (Either String Value, Env)
+exec _ _ _ (Call : _) [] = (Left "Error: stack is empty", [])
+exec depth env arg (Call : xs) stack = case Stack.pop stack of
+        (Nothing, _) -> (Left "Error: stack is empty", env)
         (Just (Op x), stack1)  -> case makeOperation x stack1 of
-               Left err -> Left err
-               Right newstack -> exec env arg xs newstack
-        (Just (Function body 0), stack1) -> case exec env [] body [] of
-                Left err -> Left err
-                Right val -> exec env arg xs (Stack.push stack1 val)
+               Left err -> (Left err, env)
+               Right newstack -> exec depth env arg xs newstack
+        (Just (Function body 0), stack1) -> case exec (depth + 1) env [] body [] of
+                (Left err, _) -> (Left err, env)
+                (Right val, env') -> exec depth (clearUntilDepth env' depth) arg xs (Stack.push stack1 val)
         (Just (Function body nb), stack1) -> case Stack.pop stack1 of
             (Just (IntVal nb'), stack2)
-                | nb' == 0 -> exec env arg xs (Stack.push stack2 (Function body nb))
-                | nb < nb' -> Left "Error: too much arguments given"
+                | nb' == 0 -> exec depth env arg xs (Stack.push stack2 (Function body nb))
+                | nb < nb' -> (Left "Error: too much arguments given", env)
                 | otherwise -> case Stack.pop stack2 of
-                    (Just v, stack3) -> exec env arg (Call:xs)
+                    (Just v, stack3) -> exec depth env arg (Call:xs)
                         (Stack.push
                             (Stack.push stack3 (IntVal (nb' - 1)))
                             (Function (Push v:PutArg:body) (nb - 1)))
-                    (Nothing, _) -> Left "Error: stack is empty"
-            (_, _) -> Left "Error: stack is invalid for a function call"
-        (Just a, _) -> Left ("Error: not an Operation or a function " ++ show a)
-exec _ [] (PushArg _:_) _ = Left "Error: no Arg"
-exec env arg (PushArg x:xs) stack
-    | x < 0 = Left "Error index out of range"
-    | x >= length arg = Left "Error: index out of range"
-    | otherwise = exec env arg xs (Stack.push stack (arg !! x))
-exec env arg (PushList x:xs) stack
-    | x < 0 = Left "Error: index out of range"
-    | x > length stack = Left "Error: index out of range"
-    | otherwise = exec env arg xs (ListVal (snd (createList x stack [])) : (fst (createList x stack [])))
-exec [] _ (PushEnv _:_) _ = Left "Error: no Env"
-exec env arg (PushEnv x:xs) stack =  case isInEnv x env of
-    Nothing -> Left "Error: not in environment"
-    Just (BoolVal b) -> exec env arg  (Push (BoolVal b):xs) stack
-    Just (IntVal i) -> exec env arg  (Push (IntVal i):xs) stack
-    Just (CharVal c) -> exec env arg  (Push (CharVal c):xs) stack
-    Just (StringVal str) -> exec env arg  (Push (StringVal str):xs) stack
-    Just (Op op) -> exec env arg (Push (Op op):xs) stack
-    Just (Function func nb) -> exec env arg (Push (Function func nb):xs) stack
-    Just (ListVal list) -> exec env arg (Push (ListVal list):xs) stack
-exec env arg (Push val:xs) stack = exec env arg xs (Stack.push stack val)
-exec env arg (PutArg:xs) stack = case Stack.pop stack of
-    (Nothing, _) -> Left "Error: stack is empty"
-    (Just val, stack1) -> exec env (arg ++ [val]) xs stack1
-exec env arg (JumpIfFalse val:xs) stack
-  | Prelude.null xs = Left "Error: no jump possible"
-  | Prelude.null stack = Left "Error: stack is empty"
-  | val < 0 = Left "Error: invalid jump value"
-  | val > length xs = Left "Error: invalid jump value"
-  | not (isBoolVal (Stack.top stack)) = Left "Error: not bool"
-  | (head stack) == BoolVal True = exec env arg xs stack
-  | otherwise = exec env arg (Prelude.drop val xs) stack
-exec env arg (JumpIfTrue val:xs) stack
-  | Prelude.null xs = Left "Error: no jump possible"
-  | Prelude.null stack = Left "Error: stack is empty"
-  | val < 0 = Left "Error: invalid jump value"
-  | val > length xs = Left "Error: invalid jump value"
-  | not (isBoolVal (Stack.top stack)) = Left "Error: not bool"
-  | (head stack) == BoolVal False = exec env arg xs stack
-  | otherwise = exec env arg (Prelude.drop val xs) stack
-exec env arg (Jump val:xs) stack
-  | Prelude.null xs = Left "Error: no jump possible"
-  | val < 0 = Left "Error: invalid jump value"
-  | val > length xs = Left "Error: invalid jump value"
-  | otherwise = exec env arg (Prelude.drop val xs) stack
-exec env arg (Define str:xs) stack = case Stack.pop stack of
-    (Nothing, _) -> Left "Error: stack is empty"
-    (Just val, stack1) -> exec (env ++ [(str, val)]) arg xs stack1
-exec _ _ (Ret : _) stack = case Stack.top stack of
-    Just x -> Right x
-    Nothing -> Left "Error: stack is empty"
-exec _ _ [] _ = Left "list no instruction found"
+                    (Nothing, _) -> (Left "Error: stack is empty", env)
+            (_, _) -> (Left "Error: stack is invalid for a function call", env)
+        (Just a, _) -> (Left ("Error: not an Operation or a function " ++ show a), env)
+exec _ _ [] (PushArg _:_) _ = (Left "Error: no Arg", [])
+exec depth env arg (PushArg x:xs) stack
+    | x < 0 = (Left "Error index out of range", env)
+    | x >= length arg = (Left "Error: index out of range", env)
+    | otherwise = exec depth env arg xs (Stack.push stack (arg !! x))
+exec depth env arg (PushList x:xs) stack
+    | x < 0 = (Left "Error: index out of range", env)
+    | x > length stack = (Left "Error: index out of range", env)
+    | otherwise = exec depth env arg xs (ListVal (snd (createList x stack [])) : (fst (createList x stack [])))
+exec _ [] _ (PushEnv _:_) _ = (Left "Error: no Env", [])
+exec depth env arg (PushEnv x:xs) stack =  case isInEnv x depth env of
+    Nothing -> (Left "Error: not in environment", env)
+    Just (BoolVal b) -> exec depth env arg  (Push (BoolVal b):xs) stack
+    Just (IntVal i) -> exec depth env arg  (Push (IntVal i):xs) stack
+    Just (CharVal c) -> exec depth env arg  (Push (CharVal c):xs) stack
+    Just (StringVal str) -> exec depth env arg  (Push (StringVal str):xs) stack
+    Just (Op op) -> exec depth env arg (Push (Op op):xs) stack
+    Just (Function func nb) -> exec depth env arg (Push (Function func nb):xs) stack
+    Just (ListVal list) -> exec depth env arg (Push (ListVal list):xs) stack
+exec depth env arg (Push val:xs) stack = exec depth env arg xs (Stack.push stack val)
+exec depth env arg (PutArg:xs) stack = case Stack.pop stack of
+    (Nothing, _) -> (Left "Error: stack is empty", env)
+    (Just val, stack1) -> exec depth env (arg ++ [val]) xs stack1
+exec depth env arg (JumpIfFalse val:xs) stack
+  | Prelude.null xs = (Left "Error: no jump possible", env)
+  | Prelude.null stack = (Left "Error: stack is empty", env)
+  | val < 0 = (Left "Error: invalid jump value", env)
+  | val > length xs = (Left "Error: invalid jump value", env)
+  | not (isBoolVal (Stack.top stack)) = (Left "Error: not bool", env)
+  | head stack == BoolVal True = exec depth env arg xs stack
+  | otherwise = exec depth env arg (Prelude.drop val xs) stack
+exec depth env arg (JumpIfTrue val:xs) stack
+  | Prelude.null xs = (Left "Error: no jump possible", env)
+  | Prelude.null stack = (Left "Error: stack is empty", env)
+  | val < 0 = (Left "Error: invalid jump value", env)
+  | val > length xs = (Left "Error: invalid jump value", env)
+  | not (isBoolVal (Stack.top stack)) = (Left "Error: not bool", env)
+  | head stack == BoolVal False = exec depth env arg xs stack
+  | otherwise = exec depth env arg (Prelude.drop val xs) stack
+exec depth env arg (Jump val:xs) stack
+  | Prelude.null xs = (Left "Error: no jump possible", env)
+  | val < 0 = (Left "Error: invalid jump value", env)
+  | val > length xs = (Left "Error: invalid jump value", env)
+  | otherwise = exec depth env arg (Prelude.drop val xs) stack
+exec depth env arg (Define str:xs) stack = case Stack.pop stack of
+    (Nothing, _) -> (Left "Error: stack is empty", env)
+    (Just val, stack1) -> case isInEnv str depth env of
+        Nothing -> exec depth ((str, val, depth):env) arg xs stack1
+        _ -> exec depth (updateInEnv str depth val env) arg xs stack1
+exec _ env _ (Ret : _) stack = case Stack.top stack of
+    Just x -> (Right x, env)
+    Nothing -> (Left "Error: stack is empty", env)
+exec _ _ _ [] _ = (Left "list no instruction found", [])

LobsterLang/test/AstOptimizerSpec.hs

@@ -162,4 +162,4 @@ spec = do
         it "Infinite recursion" $ do
             optimizeAst [Variable "eh" (FunctionValue ["x"] (Symbol "eh" (Just [Symbol "x" Nothing])) Nothing) 0] [Symbol "eh" (Just [AST.Value 1])] False `shouldBe` [Right (Warning "Possible infinite recursion" (Symbol "eh" (Just [AST.Value 1])))]
         it "Infinite recursion in define" $ do
-            optimizeAst [Variable "eh" (FunctionValue ["x"] (Symbol "eh" (Just [Symbol "x" Nothing])) Nothing) 0] [Define "a" (Symbol "eh" (Just [AST.Value 1]))] False `shouldBe` [Right (Warning "Possible infinite recursion" (Define "a" (Symbol "eh" (Just [AST.Value 1]))))]
+            optimizeAst [Variable "eh" (FunctionValue ["x"] (Symbol "eh" (Just [Symbol "x" Nothing])) Nothing) 0] [Define "a" (Symbol "eh" (Just [AST.Value 1]))] False `shouldBe` [Right (Warning "Possible infinite recursion" (Define "a" (Symbol "eh" (Just [Value 1]))))]