From 0fc79dc9496cc3bca949dd92d7a38fed270e372e Mon Sep 17 00:00:00 2001 From: Haoqiang Fan Date: Fri, 23 Dec 2016 00:24:03 +0800 Subject: [PATCH] refine standard library and interpreter --- README.md | 13 ++++--- UData.hs | 2 +- UEnvironment.hs | 32 +++++++++++---- ULambdaExpression.hs | 5 ++- UModuleLoader.hs | 5 ++- UParse.hs | 15 ++++++-- URunTime.hs | 35 +++++++++++------ a.u | 7 ---- aplusb.u | 8 ++++ helloworld.u | 4 +- io.u | 22 +++++++++-- prelude.u | 26 ++++++++++--- str.u | 33 ++++++++++++---- urepl.hs | 92 -------------------------------------------- urun.hs | 92 ++++++++++++++++++++++++++++++++++++++++++-- 15 files changed, 238 insertions(+), 153 deletions(-) delete mode 100644 a.u create mode 100644 aplusb.u delete mode 100644 urepl.hs diff --git a/README.md b/README.md index 9333ceb..0c8e600 100644 --- a/README.md +++ b/README.md @@ -17,9 +17,9 @@ Getting Started U.hs uses file extension .u. Example of helloworld.u: ``` -(import io) +(import* io) (def main (run - (_ (io.putStrLn "hello world")) + (_ (putStrLn "hello world")) (exit 0) ) ) @@ -37,12 +37,15 @@ A basic repl calculator is also included. ``` $runghc urepl.hs ; type :q to quit, :? for help ->(+ 3 1) +prelude>(+ 3 1) 4 ->(putChar 'a' (\_ (putChar '\n' exit))) -a +prelude>(import* io) +prelude io>(putStrLn "ha" print) +ha +0 >:q ``` +Note that, "print" is just the identity function (\x x). When using it as a callback, the execution is terminated with result printed. Language Specification ---------------- diff --git a/UData.hs b/UData.hs index 4814b40..051b0bf 100644 --- a/UData.hs +++ b/UData.hs @@ -78,7 +78,7 @@ applyBBinaryArith BDiv (BFloat a) (BInt b) = numToBResult (BFloat (a/(fromIntegr applyBBinaryArith BDiv (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)/b)) applyBBinaryArith BDiv (BFloat a) (BFloat b) = numToBResult (BFloat (a/b)) applyBBinaryArith BMod _ (BInt 0) = BException "mod by zero" -applyBBinaryArith BMod (BInt a) (BInt b) = numToBResult (BInt (a `div`b)) +applyBBinaryArith BMod (BInt a) (BInt b) = numToBResult (BInt (a `mod` b)) applyBBinaryArith BMod _ _ = BException "cannot use non-integer value in mod" compBNum :: BCompType -> BNum -> BNum -> Bool diff --git a/UEnvironment.hs b/UEnvironment.hs index 3326dc3..29b9a27 100644 --- a/UEnvironment.hs +++ b/UEnvironment.hs @@ -3,6 +3,8 @@ module UEnvironment where import System.IO import System.Environment import Data.Char +import System.Process +import System.Exit import Control.Monad.Trans.Class class UEnv e where @@ -15,6 +17,7 @@ class UEnv e where ePeekChar :: Int -> e Int ePutChar :: Int -> Int -> e Int eGetArg :: e Int + eSystem :: [Int] -> e Int data UEvalResult r a = URunning a | UExited Int | UExceptionHappened [Char] | UResultReturned r newtype UEvalEnv r e a = UEvalEnv {runUEvalEnv :: e (UEvalResult r a)} @@ -64,6 +67,9 @@ flGetArg (UFileList hdls (a:ar)) = (a,UFileList hdls ar) newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (a,UFileList Handle)} +liftUR :: IO a -> URealWorldEnv a +liftUR b = URealWorldEnv (\f -> (b>>=(\a -> return (a,f)))) + instance Monad URealWorldEnv where (URealWorldEnv f) >>= g = URealWorldEnv (\initfiles -> ((f initfiles) >>= (\(va,files1) -> runRealWorldEnv (g va) files1))) @@ -75,7 +81,7 @@ isValidCharInt a = (a>=0 && a<1114112) instance UEnv URealWorldEnv where eOpen filename mode = URealWorldEnv (\initfiles -> - if (mode>=0 && mode<=length efOpenModes) then + if (mode<0 || mode>=length efOpenModes) then return ((-2),initfiles) else if (any (not.isValidCharInt) filename) then return ((-3),initfiles) @@ -122,15 +128,25 @@ instance UEnv URealWorldEnv where let (ret,files1)=flGetArg initfiles in return (ret,files1) ) + eSystem cmd_int = URealWorldEnv (\initfiles -> do + if (all isValidCharInt cmd_int) then do + let cmd = map chr cmd_int + exit_code <- system cmd + case exit_code of + ExitSuccess -> return (0,initfiles) + ExitFailure a -> return (a,initfiles) + else + return ((-3),initfiles) + ) + -initRealWorldEnv :: URealWorldEnv () -initRealWorldEnv = URealWorldEnv (\oldstate -> - getArgs >>= (\args -> - let iargs = listjoin (-1) (map (map ord) args) in - return ((),UFileList [Just stdin,Just stdout] iargs))) where +initRealWorldEnv :: [[Char]] -> URealWorldEnv () +initRealWorldEnv args = URealWorldEnv (\oldstate -> + let iargs = listjoin 0 (map (map ord) args) in + return ((),UFileList [Just stdin,Just stdout] iargs)) where listjoin s [] = [] listjoin s (a:[]) = a listjoin s (a:ar) = a++(s:(listjoin s ar)) -runRealWorld :: URealWorldEnv a -> IO a -runRealWorld f = (runRealWorldEnv (initRealWorldEnv>>f)) (UFileList [] []) >>= (return.fst) +runRealWorld :: [[Char]] -> URealWorldEnv a -> IO a +runRealWorld args f = (runRealWorldEnv (initRealWorldEnv args>>f)) (UFileList [] []) >>= (return.fst) diff --git a/ULambdaExpression.hs b/ULambdaExpression.hs index 7c85370..e22afdd 100644 --- a/ULambdaExpression.hs +++ b/ULambdaExpression.hs @@ -26,7 +26,7 @@ defaultBuiltinNames = [ "/=", "=", "exit", - "open", + "openCmd", "close", "getChar", "getCharF", @@ -35,5 +35,6 @@ defaultBuiltinNames = [ "putChar", "putCharF", "getArg", - "consFileName" + "consFileName", + "systemCmd" ] diff --git a/UModuleLoader.hs b/UModuleLoader.hs index 7df73f4..e2da0a1 100644 --- a/UModuleLoader.hs +++ b/UModuleLoader.hs @@ -55,7 +55,8 @@ mAddDefs modname revimports defs c = case defs of addModuleFile :: ([Char],SPosition) -> [Char] -> [Char] -> MLoadContext -> IO (MMayFail MLoadContext) -addModuleFile caller filename modname c = do +addModuleFile caller filename modname c0 = do + let c = (\(MLoadContext loaded curchain) -> MLoadContext (Set.insert (" "++modname) loaded) curchain) c0 hasfile <- doesFileExist filename if (not hasfile) then (return$MFail ("cannot find "++filename) (fst caller) (snd caller)) else do s_mod <- loadModule filename @@ -73,7 +74,7 @@ addModuleFile caller filename modname c = do addImport :: ([Char],SPosition) -> [Char] -> MLoadContext -> IO (MMayFail MLoadContext) addImport caller modname c = let (MLoadContext loaded curchain)=c in - if (Set.member modname loaded) then (return$return c) else + if (Set.member (" "++modname) loaded) then (return$return c) else addModuleFile caller (modname++".u") modname c addImports :: ([Char],SPosition) -> [[Char]] -> MLoadContext -> IO (MMayFail MLoadContext) diff --git a/UParse.hs b/UParse.hs index 13954b9..b357792 100644 --- a/UParse.hs +++ b/UParse.hs @@ -203,6 +203,7 @@ parseSSExp (tree,sp) = case tree of STTList (((STTNode (STAtom "list")),p):r) -> constructListSugar r p STTList (((STTNode (STAtom "run")),p):r) -> constructRunSugar r p STTList (((STTNode (STAtom "do")),p):r) -> constructDoSugar r p + STTList (((STTNode (STAtom "let")),p):r) -> constructLetSugar r p STTList [] -> SFail "empty expression" sp STTList (_:[]) -> SFail "extra parenthesis" sp STTList (f:r) -> do @@ -243,7 +244,15 @@ parseSSExp (tree,sp) = case tree of (e1,p1) <- parseSSExp e (e2,p2) <- constructRunSugar r p return (SSApply (e1,p1) (SSLambda name (e2,p2),p0),p0) - constructRunSugar ((_,p1):r) p = SFail "invalid statement in do/run clause" p1 + constructRunSugar ((_,p1):r) p = SFail "invalid syntax in do/run clause" p1 + constructLetSugar [] p = SFail "empty let clause" p + constructLetSugar (h:[]) p = parseSSExp h + constructLetSugar ((STTList [(STTNode (STAtom name),p0),e],_):r) p = do + (e1,p1) <- parseSSExp e + (e2,p2) <- constructLetSugar r p + return (SSApply (SSLambda name (e2,p2),p0) (e1,p1),p0) + constructLetSugar ((_,p1):_) _ = SFail "invalid syntax in let clause" p1 + parseSSModule :: [(STokenTree,SPosition)] -> SMayFail SSModule parseSSModule trees = do @@ -258,10 +267,10 @@ parseSSModule trees = do ) where getImportBlock blocks = case blocks of [] -> SSucc ([],[]) - ((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)]),p1):r -> do + ((STTList [(STTNode (STAtom "import*"),_),(STTNode (STAtom name),_)]),p1):r -> do (sis,remain) <- getImportBlock r return ((((SSImport name SIUnqualified),p1):sis),remain) - ((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom "qualified"),_),(STTNode (STAtom name),_)]),p1):r -> do + ((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)]),p1):r -> do (sis,remain) <- getImportBlock r return ((((SSImport name SIQualified),p1):sis),remain) _ -> SSucc ([],blocks) diff --git a/URunTime.hs b/URunTime.hs index 1ca664f..c172d7f 100644 --- a/URunTime.hs +++ b/URunTime.hs @@ -7,7 +7,7 @@ import ULambdaExpression import Control.Monad.Trans.Class data VComp = VComp BCompType | VComp1 BCompType BNum deriving Show -data VSysCall = VExit | VExit1 Int | VOpen | VOpen1 [Int] | VOpen2 [Int] Int | VOpen3 [Int] Int VResult | VClose | VClose1 Int | VClose2 Int VResult | VGetChar | VGetChar1 Int | VGetChar2 Int VResult | VPeekChar | VPeekChar1 Int | VPeekChar2 Int VResult | VPutChar | VPutChar1 Int | VPutChar2 Int Int | VPutChar3 Int Int VResult | VGetArg | VGetArg1 VResult deriving Show +data VSysCall = VExit | VExit1 Int | VOpen | VOpen1 [Int] | VOpen2 [Int] Int | VOpen3 [Int] Int VResult | VClose | VClose1 Int | VClose2 Int VResult | VGetChar | VGetChar1 Int | VGetChar2 Int VResult | VPeekChar | VPeekChar1 Int | VPeekChar2 Int VResult | VPutChar | VPutChar1 Int | VPutChar2 Int Int | VPutChar3 Int Int VResult | VGetArg | VGetArg1 VResult | VSystem | VSystem1 [Int] | VSystem2 [Int] VResult deriving Show data Value = VBuiltin BValue | VAbs [Char] VExpression | VCompFunc VComp | VSys VSysCall deriving Show data VExpression = VClean Value | VApply VExpression VExpression | VRef [Char] deriving Show type VContext=Map.Map [Char] VResult @@ -38,6 +38,9 @@ showVSysCall (VPutChar2 v a) = "(putChar "++(show v)++" "++(show a)++")" showVSysCall (VPutChar3 v a _) = "(putChar "++(show v)++" "++(show a)++" ...)" showVSysCall (VGetArg) = "getArg" showVSysCall (VGetArg1 _) = "(getArg ...)" +showVSysCall (VSystem) = "system" +showVSysCall (VSystem1 v) = "(system "++(showBValue (BIntList v))++")" +showVSysCall (VSystem2 v _) = "(system "++(showBValue (BIntList v))++" ...)" showValue :: Value -> [Char] showValue (VBuiltin b) = showBValue b @@ -83,7 +86,7 @@ vBuiltInList=[ ("/=", (VCompFunc (VComp BNEq))), ("=", (VCompFunc (VComp BEq))), ("exit", (VSys (VExit))), - ("open", (VSys (VOpen))), + ("openCmd", (VSys (VOpen))), ("close", (VSys (VClose))), ("getChar", (VSys (VGetChar1 0))), ("getCharF", (VSys (VGetChar))), @@ -92,6 +95,7 @@ vBuiltInList=[ ("putChar", (VSys (VPutChar1 1))), ("putCharF", (VSys (VPutChar))), ("getArg", (VSys (VGetArg))), + ("systemCmd", (VSys (VSystem))), ("consFileName", (VBuiltin (BIntList []))) ] @@ -104,7 +108,7 @@ applyFunc :: BoundValue -> VResult -> VResult applyFunc ((VBuiltin a),ca) br = (case br of (VException e) -> VException e (VGood (VBuiltin b,_)) -> bValToVResult (applyBVal a b) - (VGood x) -> VException ("cannot feed non-builtin value to builtin value "++(show a)) + (VGood x) -> VException ("cannot feed non-builtin value to builtin value "++(showBValue a)) )where bValToVResult (BException e) = VException e bValToVResult (BClean v) = VGood (VBuiltin v,emptyContext) @@ -120,48 +124,54 @@ applyFunc (VCompFunc (VComp1 c a),_) br = case br of applyFunc (VSys VExit,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VExit1 b),emptyContext) - _ -> VException "cannot call Exit with non-integer value" + _ -> VException "cannot call exit with non-integer value" applyFunc (VSys (VExit1 _),_) _ = VException "too many arguments given to syscall exit" applyFunc (VSys VOpen,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BIntList b)),_)) -> VGood (VSys (VOpen1 b),emptyContext) - _ -> VException "cannot call Open with non-IntList filename" + _ -> VException "cannot call open with non-IntList filename" applyFunc (VSys (VOpen1 a),_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VOpen2 a b),emptyContext) - _ -> VException "cannot call Open with non-integer mode" + _ -> VException "cannot call open with non-integer mode" applyFunc (VSys (VOpen2 a b),_) br = VGood (VSys (VOpen3 a b br),emptyContext) applyFunc (VSys (VOpen3 _ _ _),_) _ = VException "too many arguments given to syscall open" applyFunc (VSys VClose,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VClose1 b),emptyContext) - _ -> VException "cannot call Close with non-integer handle" + _ -> VException "cannot call close with non-integer handle" applyFunc (VSys (VClose1 a),_) br = VGood (VSys (VClose2 a br),emptyContext) applyFunc (VSys (VClose2 _ _),_) _ = VException "too many arguments given to syscall close" applyFunc (VSys VGetChar,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VGetChar1 b),emptyContext) - _ -> VException "cannot call GetChar with non-integer handle" + _ -> VException "cannot call getChar with non-integer handle" applyFunc (VSys (VGetChar1 a),_) br = VGood (VSys (VGetChar2 a br),emptyContext) applyFunc (VSys (VGetChar2 _ _),_) _ = VException "too many arguments given to syscall getChar" applyFunc (VSys VPeekChar,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPeekChar1 b),emptyContext) - _ -> VException "cannot call PeekChar with non-integer handle" + _ -> VException "cannot call peekChar with non-integer handle" applyFunc (VSys (VPeekChar1 a),_) br = VGood (VSys (VPeekChar2 a br),emptyContext) applyFunc (VSys (VPeekChar2 _ _),_) _ = VException "too many arguments given to syscall peekChar" applyFunc (VSys VPutChar,_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPutChar1 b),emptyContext) - _ -> VException "cannot call PutChar with non-integer handle" + _ -> VException "cannot call putChar with non-integer handle" applyFunc (VSys (VPutChar1 a),_) br = case br of (VException e) -> VException e (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPutChar2 a b),emptyContext) - _ -> VException "cannot call PutChar with non-integer handle" + _ -> VException "cannot call putChar with non-integer handle" applyFunc (VSys (VPutChar2 a b),_) br = VGood (VSys (VPutChar3 a b br),emptyContext) applyFunc (VSys (VPutChar3 _ _ _),_) _ = VException "too many arguments given to syscall putChar" applyFunc (VSys VGetArg,_) br = VGood (VSys (VGetArg1 br),emptyContext) applyFunc (VSys (VGetArg1 _),_) br = VException "too many arguments given to syscall getArgs" +applyFunc (VSys VSystem,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BIntList a)),_)) -> VGood (VSys (VSystem1 a),emptyContext) + _ -> VException "cannot call system with non-IntList command" +applyFunc (VSys (VSystem1 a),_) br = VGood (VSys (VSystem2 a br),emptyContext) +applyFunc (VSys (VSystem2 _ _),_) _ = VException "too many arguments given to syscall system" evalExp :: VExpression -> VContext -> VResult evalExp (VClean v) context = VGood (v,context) @@ -196,7 +206,8 @@ executeVResult vr = case vr of (VSys (VGetChar2 f cont)) -> (lift$eGetChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) (VSys (VPeekChar2 f cont)) -> (lift$ePeekChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) (VSys (VGetArg1 cont)) -> (lift$eGetArg) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) - (VSys s) -> eException ("insufficient syscall args in "++(show s)) + (VSys (VSystem2 a cont)) -> (lift$eSystem a) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys s) -> eException ("insufficient syscall args in "++(showVSysCall s)) _ -> eReturnResult (val,context) executeVExp :: (UEnv e) => (Monad e) => VExpression -> UEvalEnv (Value,VContext) e () diff --git a/a.u b/a.u deleted file mode 100644 index f6e509d..0000000 --- a/a.u +++ /dev/null @@ -1,7 +0,0 @@ -(import io) -(import str) -(run - (a io.readInt) - (b io.readInt) - (print (+ a b)) -) diff --git a/aplusb.u b/aplusb.u new file mode 100644 index 0000000..9b71b6b --- /dev/null +++ b/aplusb.u @@ -0,0 +1,8 @@ +(import* io) +(import* str) +(run + (a readInt) + (b readInt) + (_ (putStrLn (itoa (+ a b)))) + (exit 0) +) diff --git a/helloworld.u b/helloworld.u index c01228f..bf6b2e2 100644 --- a/helloworld.u +++ b/helloworld.u @@ -1,5 +1,5 @@ -(import io) +(import* io) (run - (_ (io.putStrLn "hello world")) + (_ (putStrLn "hello world")) (exit 0) ) diff --git a/io.u b/io.u index a2cc5a5..86247a9 100644 --- a/io.u +++ b/io.u @@ -1,4 +1,4 @@ -(import str) +(import* str) ;impl helpers (let readIfF (\handle condition (do @@ -28,16 +28,30 @@ ; input (def readIntF (\handle (do - (_ (readWhileF handle str.isSpace)) + (_ (readWhileF handle isSpace)) (sign_m (readIfF handle (= '-'))) (let sign (sign_m 1 (neg 1))) - (numbers_c (readWhileF handle str.isDigit)) - (let numbers (str.atoi numbers_c)) + (numbers_c (readWhileF handle isDigit)) + (let numbers (atoi numbers_c)) (return (* sign numbers)) ) )) (def readInt (readIntF 0)) +; getArg +(let getArgStr (recur (\f (do + (a getArg) + ((< a 0) (return "") (run + (remain f) + (return (cons a remain)) + )) +)))) +(def getArgs (do + (a getArgStr) + (return (splitStr 0 a)) +)) + + ; output (def putStrF (\handle (recur (\f (\s (do (s (return 0) (\h r ( diff --git a/prelude.u b/prelude.u index 6b1d660..ead176c 100644 --- a/prelude.u +++ b/prelude.u @@ -22,11 +22,25 @@ ; the List protocol: (l null_value (\head tail list_value)) (def cons (\x xs f g (g x xs))) (def empty fst) -(def foldl (\f x0 (\recur (\g (\l +(def foldr (\f x0 (recur (\g (\l (l x0 (\x xs (f x (g xs)) - )) -))))) + ))))) +)) +(def foldl (\f (recur (\g (\x0 l + (l x0 (\x xs + (g (f x0 x) xs)) + )))) +)) +(def foldr1 (\f f1 x0 (recur (\g l + (l x0 (\x xs + (xs (f1 x) (\_ _ + (f x (g xs)) + )) + )))) +)) +(def ++ (\a b (foldr (\x y (cons x y)) b a))) +(def join (\sep (foldr1 (\x y (++ x (++ sep y))) id ""))) ; the Maybe protocol: (m nothing_value (\v just_value)) (def nothing fst) @@ -39,10 +53,12 @@ ; numeric utils (def neg (- 0)) -; filename -(def fileName (recur (\f (\name +; converting strings to built-in strings +(let fileName (recur (\f (\name (name consFileName (\h r ((f r) h)) ) )))) +(def open (\f (openCmd (fileName f)))) +(def system (\f (systemCmd (fileName f)))) diff --git a/str.u b/str.u index c404766..2a39c57 100644 --- a/str.u +++ b/str.u @@ -1,10 +1,29 @@ (def isDigit (\x (and (>= x '0') (<= x '9')))) (def isSpace (\x (or (= x ' ') (or (= x '\t') (= x '\n'))))) (def intFromDigit (\x (- x '0'))) -(def atoi (recur (\f (\y x - (x - y - (\h r (f (+ (* y 10) (intFromDigit h)) r))))) - 0) -) -(def itoa id) +(def digitFromInt (+ '0')) +(def atoi (\s (let + (atoiP (foldl (\t a (+ (* t 10) (intFromDigit a))) 0 )) + (s 0 (\h r ( + (= h '-') (neg (atoiP r)) + (atoiP s) + )))) +)) +(def itoa (\s (let + (itoaP (recur (\f (\tail x + ((<= x 9) (cons (digitFromInt x) tail) + (f (cons (digitFromInt (% x 10)) tail) (/ x 10)) + ))) "")) + ((>= s 0) (itoaP s) + (cons '-' (itoaP (neg s))) + )) +)) +(def splitStr (\d s (let + (appendHead (\a l (l (list (list a)) (\h r (cons (cons a h) r))))) + (foldr (\a r + ((= a d) (cons empty r) + (appendHead a r) + ) + ) empty s) +))) + diff --git a/urepl.hs b/urepl.hs deleted file mode 100644 index 20a5287..0000000 --- a/urepl.hs +++ /dev/null @@ -1,92 +0,0 @@ -import System.IO -import qualified Data.Set as Set - -import UParse -import URunTime -import UEnvironment -import UModuleLoader - -joinStr sep strs = case strs of - [] -> [] - a:[] -> a - a:r -> a++sep++(joinStr sep r) - -main = do - putStrLn "; type :q to quit, :? for help" - (c0,revimports0) <- tryImportFile SIUnqualified "prelude" defaultLoadContext [] - repl (c0,(Set.fromList [])) revimports0 - where - tryImportFile :: SImportMode -> [Char] -> MLoadContext -> [[Char]] -> IO (MLoadContext,[[Char]]) - tryImportFile vis modname c revimports = do - c1_m <- addImport ("main",(0,0)) modname c - case c1_m of - MFail msg modname pos -> do - putStrLn ("error loading "++modname++" at "++(show pos)++": "++msg) - return (c,revimports) - MSucc c1 -> return (c1,(if (vis == SIQualified) then revimports else (modname:revimports))) - repl :: MLocalLoadContext -> [[Char]] -> IO () - repl (c,locals) revimports = do - putStr ((joinStr " " (reverse revimports))++">") - hFlush stdout - iseof <- hIsEOF stdin - if iseof then putStrLn "" else do - line <- getLine - case line of - [] -> repl (c,locals) revimports - ':':r -> case r of - "q" -> return () - "?" -> do - putStrLn ":q quit current session" - putStrLn ":? show this help message" - putStrLn "expr compute expression" - repl (c,locals) revimports - _ -> do - putStrLn "unknown command" - repl (c,locals) revimports - _ -> case (parseSTokenTreeStr line) of - SFail msg pos -> do - putStrLn ("parser error at "++(show pos)++" "++msg) - repl (c,locals) revimports - SSucc (t,pt) -> case t of - STTList [(STTNode (STAtom "def"),_),(STTNode (STAtom name),_),(e,p)] -> tryAddDef name (e,p) SVGlobal - STTList [(STTNode (STAtom "let"),_),(STTNode (STAtom name),_),(e,p)] -> tryAddDef name (e,p) SVLocal - STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)] -> do - (c1,imports1) <- tryImportFile SIUnqualified name c revimports - repl (c1,locals) imports1 - STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom "qualified"),_),(STTNode (STAtom name),_)] -> do - (c1,imports1) <- tryImportFile SIQualified name c revimports - repl (c1,locals) imports1 - _ -> case (parseSSExp (t,pt)) of - SFail msg pos -> do - putStrLn ("parser error at "++(show pos)++" "++msg) - repl (c,locals) revimports - SSucc (e,p) -> let (MLoadContext loaded curchain) =c in - case (mResolveNames "main" (e,p) revimports loaded locals (Set.fromList [])) of - MFail msg modname pos -> do - putStrLn (msg++" at "++(show pos)) - repl (c,locals) revimports - MSucc le -> do - eval_result <- (runRealWorld$runUEvalEnv$executeVExp$fromLExpr$assembleChainLExpr curchain le) - case eval_result of - URunning () -> do - putStrLn "execution interrupted" - repl (c,locals) revimports - UExited x -> do - if (x==0) then return () else putStrLn ("exit with code "++(show x)) - repl (c,locals) revimports - UExceptionHappened f -> do - putStrLn ("exception: "++f) - repl (c,locals) revimports - UResultReturned (v,_) -> do - putStrLn (showValue v) - repl (c,locals) revimports - where - tryAddDef name (e,p) vis = case (parseSSExp (e,p)) of - SFail msg pos -> do - putStrLn (msg++" at "++(show pos)) - repl (c,locals) revimports - SSucc (se,pse) -> case (mAddDef "main" revimports (SSDef name (se,pse) vis) (c,locals)) of - MFail msg modname pos -> do - putStrLn (msg++" at "++(show pos)) - repl (c,locals) revimports - MSucc (c1,locals1) -> repl (c1,locals1) revimports diff --git a/urun.hs b/urun.hs index 70cf22a..7667504 100644 --- a/urun.hs +++ b/urun.hs @@ -1,14 +1,100 @@ import System.Environment +import System.IO import qualified Data.Set as Set +import UParse import UModuleLoader import URunTime import UEnvironment import ULambdaExpression +interactiveRun args = do + putStrLn "; type :q to quit, :? for help" + (c0,revimports0) <- tryImportFile SIUnqualified "prelude" defaultLoadContext [] + runRealWorld args$repl (c0,(Set.fromList [])) revimports0 + where + tryImportFile :: SImportMode -> [Char] -> MLoadContext -> [[Char]] -> IO (MLoadContext,[[Char]]) + tryImportFile vis modname c revimports = do + c1_m <- addImport ("main",(0,0)) modname c + case c1_m of + MFail msg modname pos -> do + putStrLn ("error loading "++modname++" at "++(show pos)++": "++msg) + return (c,revimports) + MSucc c1 -> return (c1,(if (vis == SIQualified) then revimports else (modname:revimports))) + repl :: MLocalLoadContext -> [[Char]] -> URealWorldEnv () + repl (c,locals) revimports = do + (liftUR.putStr) ((joinStr " " (reverse revimports))++">") + (liftUR.hFlush) stdout + iseof <- (liftUR.hIsEOF) stdin + if iseof then (liftUR.putStrLn) "" else do + line <- (liftUR getLine) + case line of + [] -> repl (c,locals) revimports + ':':r -> case r of + "q" -> return () + "?" -> do + (liftUR.putStrLn) ":q quit current session" + (liftUR.putStrLn) ":? show this help message" + (liftUR.putStrLn) "expr compute expression" + repl (c,locals) revimports + _ -> do + (liftUR.putStrLn) "unknown command" + repl (c,locals) revimports + _ -> case (parseSTokenTreeStr line) of + SFail msg pos -> do + (liftUR.putStrLn) ("parser error at "++(show pos)++" "++msg) + repl (c,locals) revimports + SSucc (t,pt) -> case t of + STTList [(STTNode (STAtom "def"),_),(STTNode (STAtom name),_),(e,p)] -> tryAddDef name (e,p) SVGlobal + STTList [(STTNode (STAtom "let"),_),(STTNode (STAtom name),_),(e,p)] -> tryAddDef name (e,p) SVLocal + STTList [(STTNode (STAtom "import*"),_),(STTNode (STAtom name),_)] -> do + (c1,imports1) <- liftUR$tryImportFile SIUnqualified name c revimports + repl (c1,locals) imports1 + STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)] -> do + (c1,imports1) <- liftUR$tryImportFile SIQualified name c revimports + repl (c1,locals) imports1 + _ -> case (parseSSExp (t,pt)) of + SFail msg pos -> do + (liftUR.putStrLn) ("parser error at "++(show pos)++" "++msg) + repl (c,locals) revimports + SSucc (e,p) -> let (MLoadContext loaded curchain) =c in + case (mResolveNames "main" (e,p) revimports loaded locals (Set.fromList [])) of + MFail msg modname pos -> do + (liftUR.putStrLn) (msg++" at "++(show pos)) + repl (c,locals) revimports + MSucc le -> do + eval_result <- (runUEvalEnv$executeVExp$fromLExpr$assembleChainLExpr curchain le) + case eval_result of + URunning () -> do + (liftUR.putStrLn) "execution interrupted" + repl (c,locals) revimports + UExited x -> do + if (x==0) then return () else (liftUR.putStrLn) ("exit with code "++(show x)) + repl (c,locals) revimports + UExceptionHappened f -> do + (liftUR.putStrLn) ("exception: "++f) + repl (c,locals) revimports + UResultReturned (v,_) -> do + (liftUR.putStrLn) (showValue v) + repl (c,locals) revimports + where + tryAddDef :: [Char] -> (STokenTree,SPosition) -> SVisibility -> URealWorldEnv () + tryAddDef name (e,p) vis = case (parseSSExp (e,p)) of + SFail msg pos -> do + (liftUR.putStrLn) (msg++" at "++(show pos)) + repl (c,locals) revimports + SSucc (se,pse) -> case (mAddDef "main" revimports (SSDef name (se,pse) vis) (c,locals)) of + MFail msg modname pos -> do + (liftUR.putStrLn) (msg++" at "++(show pos)) + repl (c,locals) revimports + MSucc (c1,locals1) -> repl (c1,locals1) revimports + joinStr sep strs = case strs of + [] -> [] + a:[] -> a + a:r -> a++sep++(joinStr sep r) main = do args <- getArgs - if (length args)/=1 then - putStrLn "Usage: urun filename.u" + if null args || ((head args) == "-") then + interactiveRun (drop 1 args) else do let ifname = head args loadc <- loadMainModule ifname defaultLoadContext @@ -17,7 +103,7 @@ main = do MSucc (MLoadContext loaded curchain) | (not (Set.member "main.main" loaded)) -> putStrLn "main.main not defined" | otherwise -> do - eval_result <- (runRealWorld$runUEvalEnv$executeVExp$fromLExpr$assembleChainLExpr curchain (LRef "main.main")) + eval_result <- (runRealWorld (tail args)$runUEvalEnv$executeVExp$fromLExpr$assembleChainLExpr curchain (LRef "main.main")) case eval_result of URunning () -> putStrLn "execution interrupted" UExited x -> if (x==0) then return () else putStrLn ("exit with code "++(show x))