shithub: MicroHs

Download patch

ref: 75f35221224c8c5c4da65675125d99e05d60bc41
parent: a8308e68a3bc58aa85203174b241630c107e1604
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Sep 20 16:43:23 EDT 2023 

Various changes for an interactive version.

Not ready yet.


--- a/Makefile
+++ b/Makefile
@@ -34,7 +34,7 @@
 ### Build the compiler with ghc, using standard libraries (Prelude, Data.List, etc)
 ###
 $(BIN)/$(MHS):	src/*.hs src/*/*.hs $(TOOLS)/convertX.sh
-	$(GHCE) -isrc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
+	$(GHCE) -isrc -ighc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
 
 ###
 ### Build the compiler with ghc, using MicroHs libraries (Prelude, Data.List, etc)
@@ -68,6 +68,7 @@
 	$(GHCC) -c lib/Data/Integer.hs
 	$(GHCC) -c lib/Control/Monad/State/Strict.hs
 #	$(GHCC) -c lib/Debug/Trace.hs
+	$(GHCC) -c lib/System/Console/SimpleReadline.hs
 	$(GHCC) -c src/Text/ParserComb.hs
 	$(GHCC) -c src/MicroHs/Ident.hs
 	$(GHCC) -c src/MicroHs/Expr.hs
@@ -84,8 +85,9 @@
 	$(GHCC) -c src/MicroHs/StateIO.hs
 	$(GHCC) -c src/MicroHs/Compile.hs
 	$(GHCC) -c src/MicroHs/Translate.hs
+	$(GHCC) -c src/MicroHs/Interactive.hs
 	$(GHCC) -c -main-is MicroHs.Main src/MicroHs/Main.hs
-	$(GHC) $(PROF) -hide-all-packages -package time -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*/*.o
+	$(GHC) $(PROF) -hide-all-packages -package time -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*.o $(BOOTDIR)/*/*/*/*.o
 #	$(GHC) $(PROF) -hide-all-packages -package containers -o $(BIN)/boot$(MHS) $(BOOTDIR)/*.o $(BOOTDIR)/*/*.o $(BOOTDIR)/*/*/*/*.o
 
 # Compare version compiled with normal GHC libraries and $(MHS) libraries
@@ -138,7 +140,7 @@
 ###
 ### Make an eval.c that contains the combinator code.
 ###
-tmp/eval.c: src/runtime/eval.c $(BIN)/eval
+tmp/eval.c: src/runtime/eval.c $(BIN)/eval $(COMB)$(MHS).comb 
 	@mkdir -p tmp
 	cp src/runtime/eval.c tmp/eval.c
 	$(BIN)/eval +RTS -K10M -r$(COMB)$(MHS).comb -RTS -ilib -iTools -r Addcombs -- $(COMB)$(MHS).comb >> tmp/eval.c
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v3.4
-854
-(($A :0 ((_649 _598) (($B ((($S' ($C ((($C' ($S' _649)) (($B ($C _2)) _581)) (($B ($B (_649 _678))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _650)) ((($C' $B) (($B _747) (($B _668) ((($C' _783) _9) 0)))) (($B (_747 _671)) (($B (_684 "top level defns: ")) _629)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _650)) ((($C' $B) (($B _747) (($B _668) ((($C' _783) _9) 1)))) (_667 ($T (($B ($B (_747 _671))) ((($C' $B) (($B _684) ((($C' _684) _587) " = "))) (($C _407) $K))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _10))) ((($S' $B) (($B ($C' ($C' _650))) ((($C' $B) ($B' (($B _747) (($B _673) _12)))) (($B _684) ((($C' _684) (($B (_684 _1)) _629)) (($O 10) $K)))))) (($B ($B (_649 _678))) ((($C' $B) ($B' (($B _747) (($B _668) ((($C' _783) _9) 0))))) (($B ($B (_747 _671))) ((($C' ($C' _684)) (($B ($B (_684 "final pass            "))) (($B ($B (_643 6))) (($B ($B _629)) _777)))) "ms"))))))) _3))))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _689)) _407))) (($C _702) (_718 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _748) (($B _684) ((($C' _684) (($B (_684 "(($A :")) _629)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _748)) ($B _407))) (($B (_748 (_684 ") "))) (($C _748) (_684 (($O 41) $K)))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _382)) $I))) ($BK $K))) $K))))) (($B (($S' _747) (($B _744) (($B (_747 _792)) (($B (_684 "main: findIdent: ")) _587))))) (($C' _617) _584)))) _624))) (($B ($B _621)) ((($C' $B) (($B _686) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _584))) $K)))))) (($C _702) (_718 0))))))) ($T $A))) ($T $K))) $I)) (($B (_747 _381)) (($B (_747 _581)) (($B (_684 (($O 95) $K))) _629)))))))) (($S (($S ((($S' _8) (($B _701) (_688 (_641 "-v")))) ((_717 _641) "-r"))) (($B (_682 (($O 46) $K))) (($B _746) (_687 ((_706 _768) "-i")))))) (($B (_747 _713)) ((($C' _684) (($B _746) (_687 ((_706 _768) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _779) _701) 1)) (_792 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _713)) (_688 ((_748 _788) ((_748 (_641 (($O 45) $K))) (_699 1))))))) (_709 ((_748 _788) (_641 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _649)) _17) (($B ($B ($B (_649 _678)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _649) (($B _651) (_740 _225)))))) (($B ($B ($B ($B $T)))) (($B ($B ($B ($B (_649 _678))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _650))) ((($C' $B) ($B' (($B _747) (($B _668) ((($C' _783) _9) 0))))) (($B ($B (_747 _671))) ((($C' ($C' _684)) (($B ($B (_684 "combinator conversion "))) (($B ($B (_643 6))) (($B ($B _629)) _777)))) "ms")))))) (($B ($B _651)) (($B $P) (($C _590) (_581 "main"))))))))) (_686 ($T ((($C' ($C' $O)) ((($C' $B) $P) _410)) $K))))))) (($A :3 (($B (_649 _598)) (($B (($C' _599) ((($C' _772) (($B _701) (_709 ((_748 _788) (_641 "--"))))) 1))) (($B (_747 _7)) _4)))) (($A :4 ($T (($C ((($C' $C') (($B $S) ($C $C))) (($B ($B $Y)) (($B ($B ($B _571))) (($C' ($C' _686)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _5))) $K))))))) (($B (($S' _747) (($B _744) (($B (_747 _792)) (($B (_684 "not found ")) _587))))) ($C _572))))) (($A :5 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _7)) _5)) _5))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _7)) $K))) ((($C' $B) _5) _409))) ((($S' _747) (($B _744) (($B (_747 _792)) (_684 "primlookup: ")))) (($C (_723 _641)) _6)))) $K))) (_792 "trans: impossible"))) (($A :6 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67)
\ No newline at end of file
+871
+(($A :0 ((_663 _612) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _595)) ($K ($K (_807 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _21) (($B _716) (_703 (_655 "-v")))) ((_732 _655) "-r"))) (($B (_697 (($O 46) $K))) (($B _761) (_702 ((_721 _783) "-i")))))) (($B (_762 _728)) ((($C' _699) (($B _761) (_702 ((_721 _783) "-o")))) (($O "out.comb") $K))))) (_703 ((_763 _803) ((_763 (_655 (($O 45) $K))) (_714 1)))))) (_724 ((_763 _803) (_655 "--")))))) (($A :1 ((($S' ($S' _663)) _30) (($B ($B ($B (_663 _693)))) ((($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 _664)) ((($C' $B) (($B _762) (($B _683) ((($C' _798) _22) 0)))) (($B (_762 _686)) (($B (_699 "top level defns: ")) _643)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _664)) ((($C' $B) (($B _762) (($B _683) ((($C' _798) _22) 1)))) (_682 ($T (($B ($B (_762 _686))) ((($C' $B) (($B _699) ((($C' _699) _601) " = "))) (($C _421) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _23))) ((($S' $B) (($B ($C' ($C' _664))) ((($C' $B) ($B' (($B _762) (($B _688) _25)))) (($B _699) ((($C' _699) (($B (_699 _2)) _643)) (($O 10) $K)))))) (($B ($B (_663 _693))) ((($C' $B) ($B' (($B _762) (($B _683) ((($C' _798) _22) 0))))) (($B ($B (_762 _686))) ((($C' ($C' _699)) (($B ($B (_699 "final pass            "))) (($B ($B (_657 6))) (($B ($B _643)) _792)))) "ms"))))))) _16))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _704)) _421))) (($C _717) (_733 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _763) (($B _699) ((($C' _699) (($B (_699 "(($A :")) _643)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _763)) ($B _421))) (($B (_763 (_699 ") "))) (($C _763) (_699 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _396)) $I))) ($BK $K))) $K))))) (($B (($S' _762) (($B _759) (($B (_762 _807)) (($B (_699 "main: findIdent: ")) _601))))) (($C' _631) _598)))) _638))) (($B ($B _635)) (($B (($C' _701) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _598))) $K)))))) (($C _717) (_733 0))))))) (($C _604) (_595 "main")))) (($B (_762 _395)) (($B (_762 _595)) (($B (_699 (($O 95) $K))) _643))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_664 (_686 "Type ':quit' to quit"))) ((($C' _663) (($B (_569 _5)) ($P _4))) ($K (_665 _809))))) (($A :4 ((_699 ((_699 ((_699 ((_699 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_570 ((_762 _579) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C _655) ":quit")) ((($C' _571) _9) _5))) ((_762 _579) (_686 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _699) (_699 ((_699 ((_699 ((_699 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) (($O 41) $K))) (($A :9 (($B (_570 _578)) (($B $T) ((($S' ($S' $B)) (($B ($B _570)) (($B ($B _10)) (($B (($C' _699) (($C _699) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _570) _10)) (($B ($B ($P (($B (_762 _579)) _686)))) (($B $BK) (($B ($B _577)) ($C $P))))))) (($C' _699) (($C _699) (($O 10) $K)))))) _11))))) (($A :10 ((($C' _571) (($B (_762 _579)) (_688 ((_699 _6) ".hs")))) ((_570 (_574 _771)) ((($C' _570) (($B (_762 _579)) (($C _30) (_595 _6)))) (($B _572) _774))))) (($A :11 (($B (($B (_762 _579)) (($S (($C _867) (_686 "Type must be Int or IO"))) (($B (_762 _686)) (($B (_762 _643)) _20))))) (($B _17) ($P (_595 ((_699 ((_699 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _664) _684) ((_663 (((_15 (($P _696) _696)) $K) $K)) ($T ($K _665))))) (($A :13 ((($S' $B) (($B _663) (($C _676) _659))) (($B ($B (($C' _663) (($P (_665 _696)) ((($C' _663) _690) (($B ((($S' _695) _716) _665)) _652)))))
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -167,3 +167,9 @@
 primGetTimeMilli  = floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds <$> getCurrentTime
 primGetRaw       :: IO Int
 primGetRaw        = return (-1) -- not implemented
+
+-- Temporary until overloading
+primIsInt        :: Any -> Bool
+primIsInt         = error "isInt"
+primIsIO         :: Any -> Bool
+primIsIO          = error "isIO"
--- /dev/null
+++ b/ghc/System/Console/SimpleReadline.hs
@@ -1,0 +1,4 @@
+module System.Console.SimpleReadline where
+
+getInputLineHist :: FilePath -> String -> IO (Maybe String)
+getInputLineHist _ _ = error "getInputLineHist"
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -143,3 +143,9 @@
 
 primWithDropArgs :: forall a . Int -> IO a -> IO a
 primWithDropArgs i ioa = primThen (primDropArgs i) ioa
+
+-- Temporary until overloading
+primIsInt        :: Any -> Bool
+primIsInt         = primitive "isInt"
+primIsIO         :: Any -> Bool
+primIsIO          = primitive "isIO"
--- a/lib/System/IO.hs
+++ b/lib/System/IO.hs
@@ -25,6 +25,9 @@
 return      :: forall a . a -> IO a
 return       = primReturn
 
+fail        :: forall a . String -> IO a
+fail s       = error s
+
 hSerialize   :: forall a . Handle -> a -> IO ()
 hSerialize   = primHSerialize
 hDeserialize :: forall a . Handle -> IO a
--- a/lib/Unsafe/Coerce.hs
+++ b/lib/Unsafe/Coerce.hs
@@ -1,4 +1,4 @@
-module Unsafe.Coerce(module Unsafe.Coerce, Any) where
+module Unsafe.Coerce(module Unsafe.Coerce, Any, primIsInt, primIsIO) where
 import Primitives
 
 unsafeCoerce :: forall a b . a -> b
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -10,6 +10,7 @@
 import Data.List
 import System.Environment
 import System.IO
+import GHC.Types(Any)
 
 -- Functions needed for ghc
 eqChar :: Char -> Char -> Bool
@@ -105,6 +106,9 @@
         (a2, b2) ->
           eqa a1 a2 && eqb b1 b2
 
+showPair :: (a -> String) -> (b -> String) -> (a, b) -> String
+showPair f g (a, b) = "(" ++ f a ++ "," ++ g b ++ ")"
+
 eqInt :: Int -> Int -> Bool
 eqInt = (==)
 
@@ -171,3 +175,9 @@
 neBool :: Bool -> Bool -> Bool
 neBool True  x = not x
 neBool False x = x
+
+-- Temporary until overloading
+primIsInt        :: Any -> Bool
+primIsInt         = error "isInt"
+primIsIO         :: Any -> Bool
+primIsIO          = error "isIO"
--- a/src/CompatIO.hs
+++ b/src/CompatIO.hs
@@ -14,3 +14,6 @@
 
 when :: Bool -> IO () -> IO ()
 when = M.when
+
+fail        :: forall a . String -> IO a
+fail s       = error s
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -1,7 +1,7 @@
 -- Copyright 2023 Lennart Augustsson
 -- See LICENSE file for full license.
 module MicroHs.Compile(
-  compile,
+  compile, compileTop,
   Flags(..), verbose, runIt, output
   ) where
 import Prelude --Xhiding (Monad(..), mapM, showString, showList)
@@ -13,6 +13,7 @@
 import qualified MicroHs.IdentMap as M
 import MicroHs.StateIO as S
 import MicroHs.Desugar
+import MicroHs.Exp
 import MicroHs.Expr
 import MicroHs.Ident
 import MicroHs.Parse
@@ -52,6 +53,20 @@
 
 -----------------
 
+
+--compileTop :: Flags -> IdentModule -> IO [LDef]
+compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
+compileTop flags mn = IO.do
+  ds <- compile flags mn
+  t1 <- getTimeMilli
+  let
+    dsn = [ (n, compileOpt e) | (n, e) <- ds ]
+  () <- IO.return (forceList forceLDef dsn)
+  t2 <- getTimeMilli
+  IO.when (verbose flags > 0) $
+    putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
+  IO.return dsn
+
 compile :: Flags -> IdentModule -> IO [LDef]
 compile flags nm = IO.do
   ((_, t), ch) <- runStateIO (compileModuleCached flags nm) (Cache [] M.empty)
@@ -62,7 +77,7 @@
   IO.return $ concatMap defs $ M.elems $ cache ch
 
 -- Compile a module with the given name.
--- If the module has already been compiled, return the caches result.
+-- If the module has already been compiled, return the cached result.
 compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
 compileModuleCached flags nm = S.do
   ch <- gets cache
@@ -76,7 +91,8 @@
         liftIO $ putStrLn $ "importing " ++ showIdent nm
       (cm, tp, tt, ts) <- compileModule flags nm
       S.when (verbose flags > 0) $
-        liftIO $ putStrLn $ "importing done " ++ showIdent nm ++ ", " ++ showInt (tp + tt) ++ "ms (" ++ showInt tp ++ " + " ++ showInt tt ++ ")"
+        liftIO $ putStrLn $ "importing done " ++ showIdent nm ++ ", " ++ showInt (tp + tt) ++
+                 "ms (" ++ showInt tp ++ " + " ++ showInt tt ++ ")"
       c <- get
       put $ Cache (tail (working c)) (M.insert nm cm (cache c))
       S.return (cm, tp + tt + ts)
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -485,7 +485,7 @@
     [] -> ds
     (i1:i2:_) : _ ->
       errorMessage (getSLocIdent i1) $ "Duplicate " ++ showIdent i1 ++ " " ++ showSLoc (getSLocIdent i2)
-    _ -> undefined
+    _ -> error "checkDup"
 
 forceLDef :: LDef -> ()
 forceLDef (i, e) = case forceIdent i of { () -> forceExp e }
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -114,10 +114,10 @@
             Con -> Ident
 conIdent (ConData _ i) = i
 conIdent (ConNew i) = i
-conIdent _ = undefined
+conIdent _ = error "conIdent"
 
 conArity :: Con -> Int
-conArity (ConData cs i) = fromMaybe undefined $ lookupBy eqIdent i cs
+conArity (ConData cs i) = fromMaybe (error "conArity") $ lookupBy eqIdent i cs
 conArity (ConNew _) = 1
 conArity (ConLit _) = 0
 
@@ -313,7 +313,7 @@
 setSLocExpr l (EVar i) = EVar (setSLocIdent l i)
 setSLocExpr l (ECon c) = ECon (setSLocCon l c)
 setSLocExpr l (ELit _ k) = ELit l k
-setSLocExpr _ _ = undefined  -- what other cases do we need?
+setSLocExpr _ _ = error "setSLocExpr"  -- what other cases do we need?
 
 setSLocCon :: SLoc -> Con -> Con
 setSLocCon l (ConData ti i) = ConData ti (setSLocIdent l i)
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -66,9 +66,9 @@
 unQualString s =
   case span isIdentChar s of
     ("", r) -> r
+    (r, "") -> r                       -- XXX bug!  swapping with next line goes wrong
     (_, '.':r) -> unQualString r
-    (r, "") -> r
-    _ -> undefined
+    x -> error $ "unQualString: " ++ showPair showString (showPair showString showString) (s, x)
 
 isConIdent :: Ident -> Bool
 isConIdent (Ident _ i) =
--- /dev/null
+++ b/src/MicroHs/Interactive.hs
@@ -1,0 +1,77 @@
+module MicroHs.Interactive(module MicroHs.Interactive) where
+import Prelude
+import qualified MicroHs.StateIO as S
+import MicroHs.Compile
+import MicroHs.Exp(Exp)
+import MicroHs.Ident(Ident, mkIdent)
+import MicroHs.Translate
+import Unsafe.Coerce
+import System.Console.SimpleReadline
+--Ximport Compat
+
+type LDef = (Ident, Exp)  -- XXX why?
+
+type IState = (String, Flags)
+
+type I a = S.StateIO IState a
+
+mainInteractive :: Flags -> IO ()
+mainInteractive flags = do
+  putStrLn "Type ':quit' to quit"
+  _ <- S.runStateIO repl (preamble, flags)
+  return ()
+
+preamble :: String
+preamble = "module " ++ interactiveName ++ "(module " ++ interactiveName ++ ") where\nimport Prelude\nimport Unsafe.Coerce\n"
+
+repl :: I ()
+repl = S.do
+  ms <- S.liftIO $ getInputLineHist ".mhsi" "> "
+  case ms of
+    Nothing -> repl
+    Just ":quit" -> S.liftIO $ putStrLn "Bye"
+    Just s -> S.do
+      oneline s
+      repl
+
+interactiveName :: String
+interactiveName = "Interactive"
+
+itName :: String
+itName = "_it"
+
+mkIt :: String -> String
+mkIt l = itName ++ " :: Any\n" ++ itName ++ " = unsafeCoerce (" ++ l ++ ")"
+
+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
+      let lls = ls ++ "\n" ++ line
+      defTest <- tryCompile lls
+      case defTest of
+        Right _ -> S.put (lls, flgs)
+        Left  s -> S.liftIO $ putStrLn s
+
+tryCompile :: String -> I (Either String [LDef])
+tryCompile file = S.do
+  S.liftIO $ writeFile (interactiveName ++ ".hs") file
+  flgs <- S.gets snd
+  cmdl <- S.liftIO $ compileTop flgs (mkIdent interactiveName)
+  S.return (Right cmdl)
+
+evalExpr :: [LDef] -> I ()
+evalExpr cmdl = S.do
+  let val = translate (mkIdent (interactiveName ++ "." ++ itName), cmdl)
+  S.liftIO $
+    if primIsInt val then
+      putStrLn $ showInt $ unsafeCoerce val
+{-
+    else if primIsIO val then
+      unsafeCoerce val
+-}
+    else
+      putStrLn "Type must be Int or IO"
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -7,11 +7,10 @@
 import Data.Maybe
 import System.Environment
 import MicroHs.Compile
-import MicroHs.Desugar
-import MicroHs.Expr
 import MicroHs.Exp
 import MicroHs.Ident
 import MicroHs.Translate
+import MicroHs.Interactive
 --Ximport Compat
 
 main :: IO ()
@@ -19,18 +18,23 @@
   aargs <- getArgs
   let
     args = takeWhile (not . eqString "--") aargs
-    mn =
-      let
-        ss = filter (not . (eqString "-") . take 1) args
-      in   if length ss == 1 then head ss else error "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"
+    ss = filter (not . (eqString "-") . take 1) args
     flags = Flags (length (filter (eqString "-v") args))
                   (elemBy eqString "-r" args)
                   ("." : catMaybes (map (stripPrefixBy eqChar "-i") args))
                   (head $ catMaybes (map (stripPrefixBy eqChar "-o") args) ++ ["out.comb"])
-  cmdl <- compileTop flags (mkIdent mn)
+  case ss of
+    [] -> mainInteractive flags
+    [s] -> mainCompile flags (mkIdent s)
+    _ -> error "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"
+
+mainCompile :: Flags -> Ident -> IO ()
+mainCompile flags mn = do
+  ds <- compileTop flags mn
   t1 <- getTimeMilli
   let
-    (mainName, ds) = cmdl
+    mainName = qualIdent mn (mkIdent "main")
+    cmdl = (mainName, ds)
     ref i = Var $ mkIdent $ "_" ++ showInt i
     defs = M.fromList [ (unIdent n, ref i) | ((n, _), i) <- zip ds (enumFrom 0) ]
     findIdent n = fromMaybe (error $ "main: findIdent: " ++ showIdent n) $
@@ -65,17 +69,3 @@
 
 version :: String
 version = "v3.4\n"
-
-type Program = (Ident, [LDef])
-
-compileTop :: Flags -> IdentModule -> IO Program
-compileTop flags mn = do
-  ds <- compile flags mn
-  t1 <- getTimeMilli
-  let
-    dsn = [ (n, compileOpt e) | (n, e) <- ds ]
-  () <- return (forceList forceLDef dsn)
-  t2 <- getTimeMilli
-  when (verbose flags > 0) $
-    putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
-  return (qualIdent mn (mkIdent "main"), dsn)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -515,7 +515,7 @@
 -------------
 
 eTuple :: [Expr] -> Expr
-eTuple [] = undefined
+eTuple [] = error "eTuple"
 eTuple [e] = e
 eTuple es = ETuple es
 
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -13,12 +13,12 @@
 --Ximport PrimTable
 --Yimport PrimTable
 
-import MicroHs.Desugar
 import MicroHs.Expr
 import MicroHs.Exp
 import MicroHs.Ident
 
-translateAndRun :: (Ident, [LDef]) -> IO ()
+--translateAndRun :: (Ident, [LDef]) -> IO ()
+translateAndRun :: (Ident, [(Ident, Exp)]) -> IO ()
 translateAndRun defs = do
   -- Drop all argument up to '--'
   args <- getArgs
@@ -26,7 +26,8 @@
   withDropArgs (length (takeWhile (not . eqString "--") args) + 1)
     prog
 
-translate :: (Ident, [LDef]) -> Any
+--translate :: (Ident, [LDef]) -> Any
+translate :: (Ident, [(Ident, Exp)]) -> Any
 translate (mainName, ds) =
   let
     look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
@@ -100,5 +101,7 @@
   ("IO.getArgs", primitive "IO.getArgs"),
   ("IO.dropArgs", primitive "IO.dropArgs"),
   ("IO.performIO", primitive "IO.performIO"),
-  ("IO.getTimeMilli", primitive "IO.getTimeMilli")
+  ("IO.getTimeMilli", primitive "IO.getTimeMilli"),
+  ("isInt", primitive "isInt"),
+  ("isIO", primitive "isIO")
   ]
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -116,7 +116,7 @@
 
 tyQIdent :: Entry -> Ident
 tyQIdent (Entry (EVar qi) _) = qi
-tyQIdent _ = undefined
+tyQIdent _ = error "tyQIdent"
 
 constrsOf :: Ident -> [(Ident, [Entry])] -> [ValueExport]
 constrsOf qi ies =
@@ -132,7 +132,7 @@
 getAppCon :: EType -> Ident
 getAppCon (EVar i) = i
 getAppCon (EApp f _) = getAppCon f
-getAppCon _ = undefined
+getAppCon _ = error "getAppCon"
 
 eVarI :: SLoc -> String -> Expr
 eVarI loc = EVar . mkIdentSLoc loc
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -157,6 +157,7 @@
                 T_IO_GETTIMEMILLI, T_IO_PRINT,
                 T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH,
                 T_STR,
+                T_ISINT, T_ISIO,
                 T_LAST_TAG,
 };
 
@@ -458,6 +459,8 @@
   { "IO.dropArgs", T_IO_DROPARGS },
   { "IO.getTimeMilli", T_IO_GETTIMEMILLI },
   { "IO.performIO", T_IO_PERFORMIO },
+  { "isInt", T_ISINT },
+  { "isIO", T_ISIO },
 };
 
 void
@@ -1137,6 +1140,8 @@
   case T_IO_GETTIMEMILLI: fprintf(f, "$IO.getTimeMilli"); break;
   case T_IO_PERFORMIO: fprintf(f, "$IO.performIO"); break;
   case T_IO_CCALL: fprintf(f, "#%s", ffi_table[GETVALUE(n)].ffi_name); break;
+  case T_ISINT: fprintf(f, "$isInt"); break;
+  case T_ISIO: fprintf(f, "$isIO"); break;
   default: ERR("print tag");
   }
 }
@@ -1492,6 +1497,19 @@
     case T_IO_GETTIMEMILLI:
     case T_IO_CCALL:
       RET;
+
+    case T_ISINT:
+      CHECK(1);
+      x = evali(ARG(TOP(0)));
+      POP(1);
+      GOIND(GETTAG(x) == T_INT ? comTrue : combFalse);
+
+    case T_ISIO:
+      CHECK(1);
+      x = evali(ARG(TOP(0)));
+      POP(1);
+      l = GETTAG(x);
+      GOIND(T_IO_BIND <= l && l <= T_IO_FLUSH ? comTrue : combFalse);
 
     default:
       fprintf(stderr, "bad tag %d\n", GETTAG(n));
-- 
⑨