Added free command (doesn't really work though)

3 files changed, 35 insertions, 20 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index 331ab8d..5b0c9d0 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -22,6 +22,7 @@ import           System.Console.Haskeline
 import           System.Directory
 import           System.Environment
 import           System.FilePath.Posix          ( takeBaseName )
+import           System.Mem
 import           Text.Megaparsec         hiding ( State
                                                 , try
                                                 )
@@ -242,6 +243,27 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
              _ -> pure s
     | otherwise
     -> pure s
+  ClearState -> do -- TODO: actually free memory :/
+    putStr "Currently allocated: "
+    getAllocationCounter >>= putStr . show . (0 -)
+    putStrLn " Byte"
+    performGC
+    pure $ EnvState (Environment M.empty) conf (EnvCache M.empty)
+  Time e -> do
+    start <- getTime Monotonic
+    _     <- evalInstruction (ContextualInstruction (Evaluate e) inp)
+                             s
+                             (const $ pure s)
+    end <- getTime Monotonic
+    let roundSecs x =
+          (fromIntegral (round $ x * 1e6 :: Integer)) / 1e6 :: Double
+    putStr
+      $ show
+      $ roundSecs
+      $ (fromIntegral $ toNanoSecs $ diffTimeSpec start end :: Double)
+      / 1e9
+    putStrLn " seconds"
+    pure s
 
 -- TODO: Reduce redundancy
 showResult :: Expression -> Expression -> Environment -> IO ()
@@ -285,19 +307,6 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec =
       yeet s' (c : cs') = do
         s'' <- s'
         yeet (evalCommand inp s'' c) cs'
-    Time e -> do
-      start <- getTime Monotonic
-      _     <- evalInstruction (ContextualInstruction (Evaluate e) inp) s rec
-      end   <- getTime Monotonic
-      let roundSecs x =
-            (fromIntegral (round $ x * 1e6 :: Integer)) / 1e6 :: Double
-      putStr
-        $ show
-        $ roundSecs
-        $ (fromIntegral $ toNanoSecs $ diffTimeSpec start end :: Double)
-        / 1e9
-      putStrLn " seconds"
-      rec s
     _ -> rec s
 evalInstruction instr s rec =
   evalInstruction (ContextualInstruction instr "<unknown>") s rec
diff --git a/src/Helper.hs b/src/Helper.hs
index 97de641..6f17b15 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -136,9 +136,9 @@ instance Show Expression where
   show (MixfixChain ms) =
     "\ESC[33m(\ESC[0m" <> (intercalate " " $ map show ms) <> "\ESC[33m)\ESC[0m"
   show (Prefix p e) = show p <> " " <> show e
-data Command = Input String | Import String String | Test Expression Expression
+data Command = Input String | Import String String | Test Expression Expression | ClearState | Time Expression
   deriving (Show)
-data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Time Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
+data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
   deriving (Show)
 
 data EvalConf = EvalConf
diff --git a/src/Parser.hs b/src/Parser.hs
index 92c33df..b572f9a 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -265,12 +265,17 @@ parseComment = do
   _ <- some $ noneOf "\r\n"
   return ()
 
-parseTime :: Parser Instruction
+parseTime :: Parser Command
 parseTime = do
   _ <- string ":time" <* sc <?> "time instruction"
   e <- parseExpression
   pure $ Time e
 
+parseClearState :: Parser Command
+parseClearState = do
+  _ <- string ":free" <?> "free instruction"
+  pure ClearState
+
 parseImport :: Parser Command
 parseImport = do
   _    <- string ":import" <* sc <?> "import instruction"
@@ -321,8 +326,9 @@ parseBlock lvl =
 parseReplLine :: Parser Instruction
 parseReplLine =
   try parseReplDefine -- TODO: This is kinda hacky
-    <|> ((Commands . (: [])) <$> (try parseTest))
-    <|> ((Commands . (: [])) <$> (try parseInput))
-    <|> ((Commands . (: [])) <$> (try parseImport))
-    <|> try parseTime
+    <|> ((Commands . (: [])) <$> try parseTest)
+    <|> ((Commands . (: [])) <$> try parseInput)
+    <|> ((Commands . (: [])) <$> try parseImport)
+    <|> ((Commands . (: [])) <$> try parseTime)
+    <|> ((Commands . (: [])) <$> try parseClearState)
     <|> try parseEvaluate