aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs2
-rw-r--r--src/Eval.hs123
-rw-r--r--src/Helper.hs43
-rw-r--r--src/Optimizer.hs71
4 files changed, 146 insertions, 93 deletions
diff --git a/src/Binary.hs b/src/Binary.hs
index acf20d4..a6e8ceb 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -62,5 +62,3 @@ fromJot = worker . reverse
worker ('0' : xs) = Application (Application (worker xs) s) k
worker ('1' : xs) = Application s (Application k (worker xs))
worker _ = Abstraction (Bruijn 0)
-
-
diff --git a/src/Eval.hs b/src/Eval.hs
index 426b733..f57a47c 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -18,13 +18,13 @@ import qualified Data.Map as M
import Data.Maybe
import Data.Time.Clock
import Helper
+import Optimizer
import Parser
import Paths_bruijn
import Reducer
import System.Clock
import System.Console.Haskeline
import System.Directory
-import System.Environment
import System.FilePath.Posix ( takeBaseName )
import System.Mem
import Text.Megaparsec hiding ( State
@@ -53,9 +53,9 @@ split a@(_ : _) b@(c : _)
where rest = split a $ tail b
-- TODO: Force naming convention for namespaces/files
-loadFile :: String -> EvalConf -> EnvCache -> IO EnvState
-loadFile path conf cache = do
- f <- try $ readFile path :: IO (Either IOError String)
+loadFile :: EvalConf -> EnvCache -> IO EnvState
+loadFile conf cache = do
+ f <- try $ readFile (_path conf) :: IO (Either IOError String)
case f of
Left exception ->
print
@@ -67,7 +67,7 @@ loadFile path conf cache = do
(filter (not . null) $ split "\n\n" f')
(EnvState
(Environment M.empty)
- (conf { _isRepl = False, _evalPaths = path : _evalPaths conf })
+ (conf { _isRepl = False, _evalPaths = _path conf : _evalPaths conf })
cache
)
@@ -148,7 +148,7 @@ evalQuote f sub = evalExp f sub >>= \case
evalUnquote :: Expression -> Environment -> EvalState (Failable Expression)
evalUnquote f sub = evalExp f sub >>= \case
Left e -> pure $ Left e
- Right f' -> pure $ Right $ Unquote $ unsafeReduce f'
+ Right f' -> pure $ Right $ Unquote $ unsafeReduce f' -- TODO: REMOVE UNSAFE
evalExp :: Expression -> Environment -> EvalState (Failable Expression)
evalExp idx@(Bruijn _ ) = const $ pure $ Right idx
@@ -204,8 +204,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
in pure $ s { _env = Environment $ M.union env' envDefs }
else do
EnvState (Environment env') _ cache' <- loadFile
- full
- (conf { _nicePath = path })
+ (conf { _nicePath = path, _path = full })
cache -- TODO: Fix wrong `within` in import error
let cache'' = cache
{ _imported = M.insert path (Environment env')
@@ -252,8 +251,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
pure $ s { _env = Environment $ M.union env'' envDefs }
else do
EnvState (Environment env') _ cache' <- loadFile
- full
- (conf { _nicePath = path })
+ (conf { _nicePath = path, _path = full })
cache -- TODO: Fix wrong `within` in import error
let
cache'' = cache
@@ -298,7 +296,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
Left err -> print err
Right e' -> do
print $ length $ toBinary e'
- red <- reduce e'
+ red <- optimizedReduce conf e'
print $ length $ toBinary red
pure s
Blc e -> do
@@ -307,7 +305,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
Left err -> print err
Right e' -> do
putStrLn $ toBinary e'
- red <- reduce e'
+ red <- optimizedReduce conf e'
putStrLn $ toBinary red
pure s
Jot str -> do
@@ -319,7 +317,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
print e
print e'
print $ length $ toBinary e'
- red <- reduce e'
+ red <- optimizedReduce conf e'
print red
print $ length $ toBinary red
pure s
@@ -328,8 +326,8 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
let (res, _) = evalExp e (Environment M.empty) `runState` env
end <- case res of
Left err -> print err >> getTime Monotonic
- Right e' -> do
- red <- reduce e'
+ Right e' -> do -- TODO: should timing not include optimization time?
+ red <- optimizedReduce conf e'
deepseq red (getTime Monotonic)
let roundSecs x = fromIntegral (round $ x * 1e6 :: Integer) / 1e6 :: Double
putStr
@@ -340,7 +338,6 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
putStrLn " seconds"
pure s
--- TODO: Reduce redundancy
showResult :: Expression -> Environment -> IO ()
showResult reduced env =
let matching = matchingFunctions reduced env
@@ -370,7 +367,7 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec =
in (case res of
Left err -> print err >> rec s
Right e' -> do
- red <- reduce e'
+ red <- optimizedReduce conf e'
showResult red env
rec s
)
@@ -402,42 +399,33 @@ eval (block : bs) s@(EnvState _ conf _) =
blockParser | _isRepl conf = parseReplLine
| otherwise = parseBlock 0
-dumpFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
-dumpFile path wr conv = do
- EnvState (Environment env) _ _ <- loadFile path
- (defaultConf path)
- (EnvCache M.empty)
+dumpFile :: EvalConf -> (a -> IO ()) -> (Expression -> a) -> IO ()
+dumpFile conf wr conv = do
+ EnvState (Environment env) _ _ <- loadFile conf (EnvCache M.empty)
case M.lookup entryFunction env of
- Nothing -> print
- $ ContextualError (UndefinedIdentifier entryFunction) (Context "" path)
+ Nothing -> print $ ContextualError (UndefinedIdentifier entryFunction)
+ (Context "" (_nicePath conf))
Just EnvDef { _exp = e } -> wr $ conv e
-evalFileConf :: String -> EvalConf -> IO ()
-evalFileConf path conf = do
- EnvState (Environment env) _ _ <- loadFile path conf (EnvCache M.empty)
+evalFileConf :: EvalConf -> IO ()
+evalFileConf conf = do
+ EnvState (Environment env) _ _ <- loadFile conf (EnvCache M.empty)
arg <- encodeStdin
case M.lookup entryFunction env of
- Nothing -> print
- $ ContextualError (UndefinedIdentifier entryFunction) (Context "" path)
+ Nothing -> print $ ContextualError (UndefinedIdentifier entryFunction)
+ (Context "" (_nicePath conf))
Just EnvDef { _exp = e } -> do
- red <- reduce $ Application e arg
+ red <- optimizedReduce conf (Application e arg)
showResult red (Environment env)
-evalFile :: String -> IO ()
-evalFile path = evalFileConf path (defaultConf path)
-
--- TODO: Merge with evalFile
-evalYolo :: String -> IO ()
-evalYolo path = evalFileConf path (defaultConf path) { _evalTests = False }
-
-exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
-exec path rd conv = do
- f <- rd path
+exec :: EvalConf -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
+exec conf rd conv = do
+ f <- rd (_path conf)
arg <- encodeStdin
case f of
Left exception -> print (exception :: IOError)
Right f' -> do
- red <- reduce $ Application e arg
+ red <- optimizedReduce conf (Application e arg)
showResult red (Environment M.empty)
where e = fromBinary $ conv f'
@@ -469,18 +457,12 @@ completionSettings history = Settings
, autoAddHistory = True
}
-runRepl :: IO ()
-runRepl = do
+runRepl :: EvalConf -> IO ()
+runRepl conf = do
config <- getDataFileName "config"
history <- getDataFileName "history"
prefs <- readPrefs config
- let -- TODO: Use -y in repl for YOLO lifestyle
- conf = EvalConf { _isRepl = True
- , _evalTests = True
- , _nicePath = "<repl>"
- , _evalPaths = []
- }
- looper = runInputTWithPrefs
+ let looper = runInputTWithPrefs
prefs
(completionSettings history)
(withInterrupt $ repl $ EnvState (Environment M.empty)
@@ -491,31 +473,16 @@ runRepl = do
looper
(EnvState (Environment M.empty) conf (EnvCache M.empty))
-usage :: IO ()
-usage = do
- putStrLn "Invalid arguments. Use 'bruijn [option] path' instead"
- putStrLn "-b\tcompile path to binary-BLC"
- putStrLn "-B\tcompile path to ASCII-BLC"
- putStrLn "-e\texecute path as binary-BLC"
- putStrLn "-E\texecute path as ASCII-BLC"
- putStrLn "-y\tdisable execution of tests - YOLO"
- putStrLn "-*\tshow this help"
- putStrLn "<default>\texecute path as text-bruijn"
-
-evalMain :: IO ()
-evalMain = do
- -- TODO: use actual args parser
- args <- getArgs
- case args of
- [] -> runRepl
- ["-b", path] -> dumpFile path
- (Byte.putStr . Bit.realizeBitStringLazy)
- (toBitString . toBinary)
- ["-B", path] -> dumpFile path putStrLn toBinary
- ["-e", path] ->
- exec path (try . Byte.readFile) (fromBitString . Bit.bitStringLazy)
- ["-E", path] -> exec path (try . readFile) id
- ["-y", path] -> evalYolo path
- ['-' : _] -> usage
- [path ] -> evalFile path
- _ -> usage
+evalMain :: Args -> IO ()
+evalMain args = do
+ let conf = argsToConf args
+ case _argMode args of
+ ArgEval | _isRepl conf -> runRepl conf
+ ArgEval | otherwise -> evalFileConf conf
+ ArgDumpBblc -> dumpFile conf
+ (Byte.putStr . Bit.realizeBitStringLazy)
+ (toBitString . toBinary)
+ ArgDumpBlc -> dumpFile conf putStrLn toBinary
+ ArgEvalBblc ->
+ exec conf (try . Byte.readFile) (fromBitString . Bit.bitStringLazy)
+ ArgEvalBlc -> exec conf (try . readFile) id
diff --git a/src/Helper.hs b/src/Helper.hs
index df1918b..b1dc5f6 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -15,7 +15,9 @@ import qualified Data.ByteString.Lazy as Byte
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List
import qualified Data.Map as M
-import Data.Maybe ( fromMaybe )
+import Data.Maybe ( fromMaybe
+ , isNothing
+ )
import GHC.Generics ( Generic )
import Text.Megaparsec
@@ -42,7 +44,7 @@ printContext (Context inp path) = p $ lines inp
errPrefix :: String
errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m "
-data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String
+data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String | OptimizerError String
instance Show Error where
show (ContextualError err ctx) = show err <> "\n" <> printContext ctx
@@ -69,7 +71,8 @@ instance Show Error where
<> show red1
<> " = "
<> show red2
- show (ImportError path) = errPrefix <> "invalid import " <> show path
+ show (ImportError path) = errPrefix <> "invalid import " <> show path
+ show (OptimizerError msg ) = errPrefix <> "optimizer failed: " <> msg
type Failable = Either Error
@@ -165,11 +168,22 @@ data Command = Input String | Watch String | Import String String | Test Express
data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
deriving (Show)
+data ArgMode = ArgEval | ArgEvalBblc | ArgEvalBlc | ArgDumpBblc | ArgDumpBlc
+
+data Args = Args
+ { _argMode :: ArgMode
+ , _argNoTests :: Bool
+ , _argOptimizeTarget :: String
+ , _argPath :: Maybe String
+ }
+
data EvalConf = EvalConf
- { _isRepl :: Bool
- , _evalTests :: Bool
- , _nicePath :: String
- , _evalPaths :: [String]
+ { _isRepl :: Bool
+ , _evalTests :: Bool
+ , _nicePath :: String
+ , _path :: String
+ , _evalPaths :: [String]
+ , _optimizeTarget :: String
}
newtype ExpFlags = ExpFlags
@@ -193,12 +207,15 @@ newtype EnvCache = EnvCache
type EvalState = S.State Environment
-defaultConf :: String -> EvalConf
-defaultConf path = EvalConf { _isRepl = False
- , _evalTests = True
- , _nicePath = path
- , _evalPaths = []
- }
+argsToConf :: Args -> EvalConf
+argsToConf args = EvalConf { _isRepl = isNothing $ _argPath args
+ , _evalTests = not $ _argNoTests args
+ , _path = path
+ , _nicePath = path
+ , _evalPaths = []
+ , _optimizeTarget = _argOptimizeTarget args
+ }
+ where path = fromMaybe "" (_argPath args)
defaultFlags :: ExpFlags
defaultFlags = ExpFlags { _isImported = False }
diff --git a/src/Optimizer.hs b/src/Optimizer.hs
new file mode 100644
index 0000000..3517ade
--- /dev/null
+++ b/src/Optimizer.hs
@@ -0,0 +1,71 @@
+-- MIT License, Copyright (c) 2024 Marvin Borner
+-- Ultimately, the optimizer should not be outsourced but handled directly in Haskell.
+-- For now, my BLoC format is used in combination with BLoCade the BLoC-aid.
+
+module Optimizer
+ ( optimizedReduce
+ ) where
+
+import Binary
+import Control.Exception
+import Helper
+import Reducer
+import System.IO
+import System.Process
+
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
+
+toBloc :: Expression -> IO (Failable Handle)
+toBloc e = do
+ let binary = toBinary e
+ tryBloc <- tryIO $ createProcess (proc "bloc" ["-i", "-", "--from-blc"])
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+ let bloc = case tryBloc of
+ Right (Just i, Just o, _, _) -> Just (i, o)
+ _ -> Nothing
+ case bloc of
+ Just (inH, outH) -> do
+ hPutStrLn inH binary
+ return $ Right outH
+ Nothing -> return $ Left $ OptimizerError "can't read/write to bloc"
+
+toTarget :: Expression -> String -> IO (Failable String)
+toTarget e target = do
+ maybeBloc <- toBloc e
+ case maybeBloc of
+ Left err -> return $ Left err
+ Right bloc -> do
+ blc <- tryIO $ createProcess (proc "blocade" ["-i", "-", "-t", target])
+ { std_in = UseHandle bloc
+ , std_out = CreatePipe
+ }
+ let out = case blc of
+ Left _ -> Nothing
+ Right (_, o, _, _) -> o
+ case out of
+ Just h -> do
+ content <- hGetContents h
+ return $ case content of
+ "" -> Left $ OptimizerError "blocade returned empty string"
+ _ -> Right content
+ Nothing -> return $ Left $ OptimizerError "can't read from blocade"
+
+optimizeToTarget :: Expression -> String -> IO Expression
+optimizeToTarget e target = do
+ maybeBlc <- toTarget e target
+ case maybeBlc of
+ Left err -> do
+ print err
+ reduce e -- Fallback to default reducer
+ Right blc -> reduce $ fromBinary blc
+
+-- TODO: add more targets (including other PL compilation)
+optimizedReduce :: EvalConf -> Expression -> IO Expression
+optimizedReduce conf e = do
+ let target = _optimizeTarget conf
+ case target of
+ "" -> reduce e -- No target, fallback to default reducer
+ _ -> optimizeToTarget e target