ref: 40aead3555fe28c00cb12eede5ae6423dabfab23
parent: c6a6f85900770fd7f140ef273d63a14d86fa853b
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Sep 21 10:12:07 EDT 2023
Small improvements.
--- a/README.md
+++ b/README.md
@@ -99,6 +99,23 @@
* `Translate`, convert an expression tree to its value.
* `TypeCheck`, type checker.
+## Interactive mode
+If no module name is given the compiler enters interactive mode.
+You can enter expressions to be evaluated, or top level definitions.
+Simple line editing is available.
+
+All definitions is saved in the file `Interactive.hs` and all input
+lines as saved in `.mhsi`. The latter file is read on startup so
+the command history is persisted.
+
+Available commands:
+
+* `:quit` Quit the interactive system
+* `:clear` Clear all definitions
+* `:del STR` Delete all lines that begin with `STR`
+* `expr` Evaluate expression
+* `defn` Add definition (can also be an `import`)
+
## Runtime
The runtime system is written in C and is in `eval.c`.
It uses combinators for handling variables, and has primitive operations
--- a/TODO
+++ b/TODO
@@ -7,8 +7,7 @@
* Add the possibility to save a compiler cache in a file
- Add SHA checksumming to the C code
- Use filename as the cache lookup key and SHA for validation
-* make an interactive version
- - make the runtime system catch ^C and stop execution
+* make the runtime system catch ^C and stop execution
* use pointer stack during GC instead of recursion.
* add Double primitive type
* implement Data.Integer
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-878
-(($A :0 ((_668 _617) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _600)) ($K ($K (_813 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _25) (($B _722) (_709 (_660 "-v")))) ((_738 _660) "-r"))) (($B (_703 (($O 46) $K))) (($B _767) (_708 ((_727 _789) "-i")))))) (($B (_768 _734)) ((($C' _705) (($B _767) (_708 ((_727 _789) "-o")))) (($O "out.comb") $K))))) (_709 ((_769 _809) ((_769 (_660 (($O 45) $K))) (_720 1)))))) (_730 ((_769 _809) (_660 "--")))))) (($A :1 ((($S' ($S' _668)) _34) (($B ($B ($B (_668 _699)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _669)) ((($C' $B) (($B _768) (($B _689) ((($C' _804) _26) 0)))) (($B (_768 _692)) (($B (_705 "top level defns: ")) _648)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _669)) ((($C' $B) (($B _768) (($B _689) ((($C' _804) _26) 1)))) (_688 ($T (($B ($B (_768 _692))) ((($C' $B) (($B _705) ((($C' _705) _606) " = "))) (($C _426) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _27))) ((($S' $B) (($B ($C' ($C' _669))) ((($C' $B) ($B' (($B _768) (($B _694) _29)))) (($B _705) ((($C' _705) (($B (_705 _2)) _648)) (($O 10) $K)))))) (($B ($B (_668 _699))) ((($C' $B) ($B' (($B _768) (($B _689) ((($C' _804) _26) 0))))) (($B ($B (_768 _692))) ((($C' ($C' _705)) (($B ($B (_705 "final pass "))) (($B ($B (_662 6))) (($B ($B _648)) _798)))) "ms"))))))) _20))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _710)) _426))) (($C _723) (_739 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _769) (($B _705) ((($C' _705) (($B (_705 "(($A :")) _648)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _769)) ($B _426))) (($B (_769 (_705 ") "))) (($C _769) (_705 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _401)) $I))) ($BK $K))) $K))))) (($B (($S' _768) (($B _765) (($B (_768 _813)) (($B (_705 "main: findIdent: ")) _606))))) (($C' _636) _603)))) _643))) (($B ($B _640)) (($B (($C' _707) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _603))) $K)))))) (($C _723) (_739 0))))))) (($C _609) (_600 "main")))) (($B (_768 _400)) (($B (_768 _600)) (($B (_705 (($O 95) $K))) _648))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_669 (_692 "Type ':quit' to quit"))) ((($C' _668) (($B (_574 _5)) ($P _4))) ($K (_670 _815))))) (($A :4 ((_705 ((_705 ((_705 ((_705 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_575 ((_768 _584) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) ((($C' _576) _9) _5))) ((_768 _584) (_692 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _705) (_705 ((_705 ((_705 ((_705 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) ")\10&")) (($A :9 (($B (_575 _583)) (($B $T) ((($S' ($S' $B)) (($B ($B _575)) (($B ($B _10)) (($B (($C' _705) (($C _705) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _575) _10)) (($B ($B ($P (($B (_768 _584)) _692)))) (($B $BK) (($B ($B _582)) ($C $P))))))) ((($C' ($C' _705)) ($C _705)) (($O 10) $K))))) _11))))) (($A :10 ((($C' _576) (($B (_768 _584)) (_694 ((_705 _6) ".hs")))) ((_575 (_579 _777)) (($B (_768 _584)) (($B (_768 _18)) (($C _34) (_600 _6))))))) (($A :11 (($B (($C ((($C' $B) (($B _575) (($B (_768 _584)) (($B _18) (($S _701) _670))))) (($B ($B (_768 _584))) (($S $P) ((($C' $S) (($B ($S _874)) (($B ($S (($C _875) (_692 "Type must be Int or IO")))) (($B (($C' _668) (($B _18) _24))) (($C $P) ($K (_670 _815))))))) (($B (_768 _692)) (($B (_768 _648)) _24))))))) (($B (_768 _692)) (_705 "Error: ")))) (($B _21) ($P (_600 ((_705 ((_705 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _66\ No newline at end of file
+885
+(($A :0 ((_674 _623) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _606)) ($K ($K (_820 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _27) (($B _728) (_715 (_666 "-v")))) ((_745 _666) "-r"))) (($B (_709 (($O 46) $K))) (($B _774) (_714 ((_733 _796) "-i")))))) (($B (_775 _741)) ((($C' _711) (($B _774) (_714 ((_733 _796) "-o")))) (($O "out.comb") $K))))) (_715 ((_776 _816) ((_776 (_666 (($O 45) $K))) (_726 1)))))) (_737 ((_776 _816) (_666 "--")))))) (($A :1 ((($S' ($S' _674)) _39) (($B ($B ($B (_674 _705)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 0)))) (($B (_775 _698)) (($B (_711 "top level defns: ")) _654)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 1)))) (_694 ($T (($B ($B (_775 _698))) ((($C' $B) (($B _711) ((($C' _711) _612) " = "))) (($C _431) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _29))) ((($S' $B) (($B ($C' ($C' _675))) ((($C' $B) ($B' (($B _775) (($B _700) _31)))) (($B _711) ((($C' _711) (($B (_711 _2)) _654)) (($O 10) $K)))))) (($B ($B (_674 _705))) ((($C' $B) ($B' (($B _775) (($B _695) ((($C' _811) _28) 0))))) (($B ($B (_775 _698))) ((($C' ($C' _711)) (($B ($B (_711 "final pass "))) (($B ($B (_668 6))) (($B ($B _654)) _805)))) "ms"))))))) _22))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _716)) _431))) (($C _729) (_746 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _776) (($B _711) ((($C' _711) (($B (_711 "(($A :")) _654)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _776)) ($B _431))) (($B (_776 (_711 ") "))) (($C _776) (_711 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _406)) $I))) ($BK $K))) $K))))) (($B (($S' _775) (($B _772) (($B (_775 _820)) (($B (_711 "main: findIdent: ")) _612))))) (($C' _642) _609)))) _649))) (($B ($B _646)) (($B (($C' _713) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _609))) $K)))))) (($C _729) (_746 0))))))) (($C _615) (_606 "main")))) (($B (_775 _405)) (($B (_775 _606)) (($B (_711 (($O 95) $K))) _654))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_675 (_698 "Welcome to interactive MicroHs!"))) (($B (_675 (_698 "Type ':quit' to quit"))) ((($C' _674) (($B (_579 _5)) ((($C' $C) ($P _4)) _36))) ($K (_676 _822)))))) (($A :4 ((_711 ((_711 ((_711 ((_711 "module ") _7)) "(module ")) _7)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_580 ((_775 _589) ((_15 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) (($C (($S (($C $equal) ":clear")) (($C (($S ((_733 _796) ":del ")) ((($C' _581) _11) _5))) ((($C' _581) (($B _6) (($B (_776 _664)) ((($C' _776) (($B _715) (($B (_776 _816)) (_734 _796)))) _663)))) _5)))) ((_581 (_6 (_778 _4))) _5)))) ((_775 _589) (_698 "Bye")))))) (($A :6 (($B (_775 _586)) (($B $T) (($B ($B ($B $C))) ($B $P))))) (($A :7 "Interactive") (($A :8 "_it") (($A :9 ((($C' _711) (_711 ((_711 ((_711 ((_711 _8) " :: Any\10&")) _8)) " = unsafeCoerce ("))) ")\10&")) (($A :10 (($B (_775 _698)) (_711 "Error: "))) (($A :11 (($B (_580 _588)) (($B $T) (($B $BK) (($B $BK) (($S ((($S' $S') ((_47 _50) $K)) (($B $BK) (($B ($B ((($S' _580) _12) (($B ($P (($B (_775 _589)) _10))) ($BK (($B _6) _778)))))) ((($C' ($C' _711)) ($C _711)) (($O 10) $K)))))) (($B $BK) ((($C' ($C' _580)) (($B ($B _12)) (($B (($C' _711) (($C _711) (($O 10) $K)))) _9))) (($P (($B (_775 _589)) _10)) _13))))))))) (($A :12 (($B (_580 _588)) (($B $T) (($C ((($C' $C') (($B $C') (($B $C') ($B' (($B _581) (($B (_775 _589)) (_700 ((_711 _7) ".hs")))))))) (($B (($S' ($C' ($S' _\ No newline at end of file
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -140,6 +140,11 @@
stripPrefixBy eq (c:cs) (d:ds) | eq c d = stripPrefixBy eq cs ds
| otherwise = Nothing
+isPrefixOfBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
+isPrefixOfBy _ [] _ = True
+isPrefixOfBy _ _ [] = False
+isPrefixOfBy eq (c:cs) (d:ds) = eq c d && isPrefixOfBy eq cs ds
+
splitAt :: forall a . P.Int -> [a] -> ([a], [a])
splitAt n xs = (take n xs, drop n xs)
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -186,3 +186,8 @@
newtype Exn = Exn String
deriving (Show)
instance Exception Exn
+
+isPrefixOfBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
+isPrefixOfBy _ [] _ = True
+isPrefixOfBy _ _ [] = False
+isPrefixOfBy eq (c:cs) (d:ds) = eq c d && isPrefixOfBy eq cs ds
--- a/src/CompatIO.hs
+++ b/src/CompatIO.hs
@@ -17,3 +17,6 @@
fail :: forall a . String -> IO a
fail s = error s
+
+fmap :: (a -> b) -> IO a -> IO b
+fmap = P.fmap
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -1,8 +1,10 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module MicroHs.Compile(
- compile, compileTop,
- Flags(..), verbose, runIt, output
+ compileTop,
+ Flags(..), verbose, runIt, output,
+ compileCacheTop,
+ Cache, emptyCache, deleteFromCache,
) where
import Prelude --Xhiding (Monad(..), mapM, showString, showList)
import qualified System.IO as IO
@@ -51,13 +53,17 @@
cache :: Cache -> M.Map CModule
cache (Cache _ x) = x
------------------
+emptyCache :: Cache
+emptyCache = Cache [] M.empty
+deleteFromCache :: Ident -> Cache -> Cache
+deleteFromCache mn (Cache is m) = Cache is (M.delete mn m)
---compileTop :: Flags -> IdentModule -> IO [LDef]
-compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
-compileTop flags mn = IO.do
- ds <- compile flags mn
+-----------------
+
+compileCacheTop :: Flags -> Ident -> Cache -> IO ([(Ident, Exp)], Cache)
+compileCacheTop flags mn ch = IO.do
+ (ds, ch') <- compile flags mn ch
t1 <- getTimeMilli
let
dsn = [ (n, compileOpt e) | (n, e) <- ds ]
@@ -65,16 +71,20 @@
t2 <- getTimeMilli
IO.when (verbose flags > 0) $
putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
- IO.return dsn
+ IO.return (dsn, ch')
-compile :: Flags -> IdentModule -> IO [LDef]
-compile flags nm = IO.do
- ((_, t), ch) <- runStateIO (compileModuleCached flags nm) (Cache [] M.empty)
+--compileTop :: Flags -> IdentModule -> IO [LDef]
+compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
+compileTop flags mn = IO.fmap fst $ compileCacheTop flags mn emptyCache
+
+compile :: Flags -> IdentModule -> Cache -> IO ([LDef], Cache)
+compile flags nm ach = IO.do
+ ((_, t), ch) <- runStateIO (compileModuleCached flags nm) ach
let
defs (TModule _ _ _ _ _ ds) = ds
IO.when (verbose flags > 0) $
putStrLn $ "total import time " ++ padLeft 6 (showInt t) ++ "ms"
- IO.return $ concatMap defs $ M.elems $ cache ch
+ IO.return (concatMap defs $ M.elems $ cache ch, ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -4,6 +4,7 @@
Map,
size,
empty, insert, lookup,
+ delete,
fromList, fromListWith,
toList, elems
) where
@@ -87,6 +88,8 @@
toList (Map kvs) = kvs
+delete i (Map kvs) = Map (filter (\ (k, _) -> not (eqIdent i k)) kvs)
+
{-import qualified Data.Map as M
@@ -114,3 +117,4 @@
elems :: forall v . Map v -> [v]
size :: forall v . Map v -> Int
toList :: forall v . Map v -> [(Ident, v)]
+delete :: forall v . Ident -> Map v -> Map v
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -5,6 +5,7 @@
import MicroHs.Compile
import MicroHs.Exp(Exp)
import MicroHs.Ident(Ident, mkIdent)
+import MicroHs.Parse
import MicroHs.Translate
import Unsafe.Coerce
import System.Console.SimpleReadline
@@ -12,7 +13,7 @@
type LDef = (Ident, Exp) -- XXX why?
-type IState = (String, Flags)
+type IState = (String, Flags, Cache)
type I a = S.StateIO IState a
@@ -20,7 +21,7 @@
mainInteractive flags = do
putStrLn "Welcome to interactive MicroHs!"
putStrLn "Type ':quit' to quit"
- _ <- S.runStateIO repl (preamble, flags)
+ _ <- S.runStateIO repl (preamble, flags, emptyCache)
return ()
preamble :: String
@@ -32,10 +33,19 @@
case ms of
Nothing -> repl
Just ":quit" -> S.liftIO $ putStrLn "Bye"
+ Just ":clear" -> S.do
+ updateLines (const preamble)
+ repl
+ Just s | Just del <- stripPrefixBy eqChar ":del " s -> S.do
+ updateLines (unlines . filter (not . isPrefixOfBy eqChar del) . lines)
+ repl
Just s -> S.do
oneline s
repl
+updateLines :: (String -> String) -> I ()
+updateLines f = S.modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
+
interactiveName :: String
interactiveName = "Interactive"
@@ -45,33 +55,47 @@
mkIt :: String -> String
mkIt l = itName ++ " :: Any\n" ++ itName ++ " = unsafeCoerce (" ++ l ++ ")\n"+err :: Exn -> IO ()
+err (Exn s) = putStrLn $ "Error: " ++ s
+
oneline :: String -> I ()
oneline line = S.do
- (ls, flgs) <- S.get
- exprTest <- tryCompile (ls ++ "\n" ++ mkIt line)
- case exprTest of
- Right m -> evalExpr m
- Left _ -> S.do
+ (ls, _, _) <- S.get
+ case parse pExprTop "" line of
+ Right _ -> S.do
+ -- Looks like an expressions, make it a definition
+ exprTest <- tryCompile (ls ++ "\n" ++ mkIt line)
+ case exprTest of
+ Right m -> evalExpr m
+ Left e -> S.liftIO $ err e
+ Left _ -> S.do
+ -- Not an expression, try adding it as a definition
let lls = ls ++ line ++ "\n"
defTest <- tryCompile lls
case defTest of
- Right _ -> S.put (lls, flgs)
- Left (Exn s) -> S.liftIO $ putStrLn s
+ Right _ -> updateLines (const lls)
+ Left e -> S.liftIO $ err e
tryCompile :: String -> I (Either Exn [LDef])
tryCompile file = S.do
+ (ls, flgs, cache) <- S.get
+ let
+ iid = mkIdent interactiveName
S.liftIO $ writeFile (interactiveName ++ ".hs") file
- flgs <- S.gets snd
- S.liftIO $ try $ compileTop flgs (mkIdent interactiveName)
+ res <- S.liftIO $ try $ compileCacheTop flgs iid cache
+ case res of
+ Left e -> S.return (Left e)
+ Right (m, cache') -> S.do
+ S.put (ls, flgs, deleteFromCache iid cache')
+ S.return (Right m)
evalExpr :: [LDef] -> I ()
evalExpr cmdl = S.do
let res = translate (mkIdent (interactiveName ++ "." ++ itName), cmdl)
- err s = putStrLn $ "Error: " ++ s
mval <- S.liftIO $ try (seq res (return res))
S.liftIO $
case mval of
- Left (Exn s) -> err s
+ Left e -> err e
Right val ->
if primIsInt val then
putStrLn $ showInt $ unsafeCoerce val
@@ -78,7 +102,7 @@
else if primIsIO val then do
mio <- try (unsafeCoerce val)
case mio of
- Left (Exn s) -> err s
+ Left e -> err e
Right _ -> return ()
else
putStrLn "Type must be Int or IO"
--
⑨