repl refined

README.md

@@ -18,14 +18,12 @@ Getting Started
 
 U.hs conventionally assumes file extension .u. Example of helloworld.u:
 ```
-(
 (import io)
 (def main (run
 	(_ (io.putStrLn "hello world"))
 	(exit 0)
 	)
 )
-)
 ```
 The "run" statement is syntax sugar for chaining callbacks: (run (a b) (c d) e) = (b (\\a (d (\\c e)))). All io functions use callback to get the return value. Program starts at main in the main module. Sub-modules are loaded recursively by the import statements.
 

UData.hs

@@ -38,7 +38,7 @@ showBCompType BLe = "<"
 showBCompType BGe = ">"
 showBCompType BNLe = ">="
 showBCompType BNGe = "<="
-showBCompType BEq = "=="
+showBCompType BEq = "="
 showBCompType BNEq = "/="
 
 applyBVal :: BValue -> BValue -> BResult

UEnvironment.hs

@@ -3,23 +3,45 @@ module UEnvironment where
 import System.IO
 import System.Environment
 import Data.Char
+import Control.Monad.Trans.Class
 
 class UEnv e where
-	eExit :: Int -> e ()
-	eException :: [Char] -> e ()
-	eReturnResult :: [Char] -> e ()
+	-- eExit :: Int -> e ()
+	-- eException :: [Char] -> e ()
+	-- eReturnResult :: [Char] -> e ()
 	eOpen :: [Int] -> Int -> e Int
 	eClose :: Int -> e Int
 	eGetChar :: Int -> e Int
 	ePeekChar :: Int -> e Int
 	ePutChar :: Int -> Int -> e Int
 	eGetArg :: 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)}
+
+instance (Monad e) => Monad (UEvalEnv r e) where
+	(UEvalEnv f) >>= g = UEvalEnv (f >>= (\ret -> case (ret) of
+		URunning a -> runUEvalEnv (g a)
+		UExited a -> return$UExited a
+		UExceptionHappened a -> return$UExceptionHappened a
+		UResultReturned a -> return$UResultReturned a
+		))
+	return a = UEvalEnv (return (URunning a))
+instance MonadTrans (UEvalEnv r) where
+-- f :: e a
+-- need: UEvalEnv r e a
+	lift f = UEvalEnv (f >>= (\a -> return$URunning a))
+
+eExit :: (Monad e) => Int -> UEvalEnv r e ()
+eExit a = UEvalEnv (return (UExited a))
+eException :: (Monad e) => [Char] -> UEvalEnv r e ()
+eException a = UEvalEnv (return (UExceptionHappened a))
+eReturnResult :: (Monad e) => r -> UEvalEnv r e ()
+eReturnResult a = UEvalEnv (return (UResultReturned a))
+
 efOpenModes = [ReadMode,WriteMode,AppendMode,ReadWriteMode]
--- currently, only r and w are supported
 
-data UFinishState a = URunning a | UFinished Int | UExceptionHappened [Char] | UResultReturned [Char] deriving Show
-data UFileList h = UFileList {flFiles::[Maybe h],flArgToRead::[Int]} deriving Show
+data UFileList h = UFileList [Maybe h] [Int] deriving Show
 
 flAddHandle :: h -> UFileList h -> (Int,UFileList h)
 flAddHandle h (UFileList hdls args) = findEmptySlot hdls id 0 where
@@ -40,95 +62,75 @@ flGetArg (UFileList hdls []) = ((-1),UFileList hdls [])
 flGetArg (UFileList hdls (a:ar)) = (a,UFileList hdls ar)
 
 
-newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (UFinishState a,UFileList Handle)}
+newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (a,UFileList Handle)}
 
 instance Monad URealWorldEnv where
-	-- f ::  UFileList -> IO (UFinishState a,UFileList)
-	-- g :: a -> URealWorldEnv (UFileList -> IO (UFinishState b,UFileList))
 	(URealWorldEnv f) >>= g = URealWorldEnv (\initfiles -> 
-			(f initfiles) >>= (\(finishstate1,files1) ->
-				case finishstate1 of
-					UFinished r -> return (UFinished r ,files1)
-					UExceptionHappened e -> return (UExceptionHappened e,files1)
-					UResultReturned e -> return (UResultReturned e,files1)
-					URunning va -> runRealWorldEnv (g va) files1
-			)
-		)
+			((f initfiles) >>= (\(va,files1) -> runRealWorldEnv (g va) files1)))
 	f >> g = (f >>= (const g))
-	return a = URealWorldEnv (\f -> return (URunning a,f))
+	return a = URealWorldEnv (\f -> return (a,f))
 
 isValidCharInt :: Int -> Bool
 isValidCharInt a = (a>=0 && a<1114112)
 
 instance UEnv URealWorldEnv where
-	eExit retval = URealWorldEnv (\initfiles ->
-		return (UFinished retval,initfiles))
-	eException msg = URealWorldEnv (\initfiles ->
-		return (UExceptionHappened msg,initfiles))
-	eReturnResult msg = URealWorldEnv (\initfiles ->
-		return (UResultReturned msg,initfiles))
 	eOpen filename mode = URealWorldEnv (\initfiles ->
 		if (mode>=0 && mode<=length efOpenModes) then
-			return (URunning (-2),initfiles)
+			return ((-2),initfiles)
 		else if (any (not.isValidCharInt) filename) then
-			return (URunning (-3),initfiles)
+			return ((-3),initfiles)
 		else
 			(openFile (map chr filename) (efOpenModes!!mode) >>=
 				(\handle -> ( let (fno,files1) = flAddHandle handle initfiles in
-					return (URunning fno,files1)
+					return (fno,files1)
 				)))
 		)
 	eClose fno = URealWorldEnv (\initfiles ->
 		case (flGetHandle fno initfiles) of
-			Nothing -> return (URunning (-2),initfiles)
+			Nothing -> return ((-2),initfiles)
 			Just hdl -> ( hClose hdl >> (
-				return (URunning 0,(flCloseHandle fno initfiles))
+				return (0,(flCloseHandle fno initfiles))
 				))
 		)
 	eGetChar fno = URealWorldEnv (\initfiles ->
 		case (flGetHandle fno initfiles) of
-			Nothing -> return (URunning (-2),initfiles)
+			Nothing -> return ((-2),initfiles)
 			Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of
-				False -> hGetChar hdl >>= (\c ->return (URunning (ord c),initfiles))
-				True -> return (URunning (-1),initfiles)
+				False -> hGetChar hdl >>= (\c ->return ((ord c),initfiles))
+				True -> return ((-1),initfiles)
 				)
 		)
 	ePeekChar fno = URealWorldEnv (\initfiles ->
 		case (flGetHandle fno initfiles) of
-			Nothing -> return (URunning (-2),initfiles)
+			Nothing -> return ((-2),initfiles)
 			Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of
-				False -> hLookAhead hdl >>= (\c -> return (URunning (ord c),initfiles))
-				True -> return (URunning (-1),initfiles)
+				False -> hLookAhead hdl >>= (\c -> return ((ord c),initfiles))
+				True -> return ((-1),initfiles)
 				)
 		)
 	ePutChar fno content = URealWorldEnv (\initfiles ->
 		if isValidCharInt content then
 			case (flGetHandle fno initfiles) of
-				Nothing -> return (URunning (-2),initfiles)
+				Nothing -> return ((-2),initfiles)
 				Just hdl -> ( hPutChar hdl (chr content) >> (
-					return (URunning (0),initfiles)
+					return ((0),initfiles)
 					))
 		else
-			return (URunning (-3),initfiles)
+			return ((-3),initfiles)
 		)
 	eGetArg = URealWorldEnv (\initfiles ->
 		let (ret,files1)=flGetArg initfiles in
-		return (URunning ret,files1)
+		return (ret,files1)
 		)
 
+initRealWorldEnv :: URealWorldEnv ()
 initRealWorldEnv = URealWorldEnv (\oldstate -> 
 	getArgs >>= (\args ->
 		let iargs = listjoin (-1) (map (map ord) args) in
-			return (URunning (),UFileList [Just stdin,Just stdout] iargs))) where
+			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 ()
-runRealWorld a = (runRealWorldEnv (initRealWorldEnv >> a) (UFileList [] [])) >>= (\(exitstate,_) ->
-		case exitstate of
-			UFinished 0 -> return ()
-			UFinished a -> putStrLn ("exit with code "++show a)
-			UExceptionHappened e -> putStrLn ("Exception: " ++ e)
-			UResultReturned e -> putStrLn e
-			URunning _ -> putStrLn "execution interupted"
-	)
+
+runRealWorld :: URealWorldEnv a -> IO a
+runRealWorld f = (runRealWorldEnv (initRealWorldEnv>>f)) (UFileList [] []) >>= (return.fst)

ULambdaExpression.hs

@@ -24,7 +24,7 @@ defaultBuiltinNames = [
 	">",
 	"<=",
 	"/=",
-	"==",
+	"=",
 	"exit",
 	"open",
 	"close",

UModuleLoader.hs

@@ -20,35 +20,34 @@ loadModule fname = readFile fname >>= (return . parseSSModuleStr)
 
 type MLocalLoadContext = (MLoadContext,Set.Set [Char])
 
+getLocalName modname a = " "++modname++"."++a
+mResolveNames :: [Char] -> (SSExp,SPosition) -> [[Char]] -> (Set.Set [Char]) -> (Set.Set [Char]) -> (Set.Set [Char]) -> MMayFail LExpr
+mResolveNames modname (e,p) revimports loaded locals c = case e of
+	(SSInt a) -> return (LInt a)
+	(SSDouble a) -> return (LDouble a)
+	(SSLambda a (e1,p1)) -> do
+		e2 <- mResolveNames modname (e1,p1) revimports loaded locals (Set.insert a c)
+		return (LAbs a e2)
+	(SSRef a)
+		| (Set.member a c) -> return$LRef a
+		| (Set.member a loaded) -> return$LRef a
+		| (Set.member a locals) -> return$LRef$getLocalName modname a
+		| (Set.member (modname++"."++a) loaded) -> return$LRef$(modname++"."++a)
+		| otherwise -> case (filter (\x -> (Set.member (x++"."++a) loaded)) revimports) of
+			[] -> MFail ("undefined symbol "++a) modname p
+			(x:_) -> return$LRef (x++"."++a)
+	(SSApply (e1,p1) (e2,p2)) -> do
+		re1 <- mResolveNames modname (e1,p1) revimports loaded locals c
+		re2 <- mResolveNames modname (e2,p2) revimports loaded locals c
+		return$LApply re1 re2
 mAddDef :: [Char] -> [[Char]] -> SSDef -> MLocalLoadContext -> MMayFail MLocalLoadContext
 mAddDef modname revimports (SSDef name (se,sp) vis) ((MLoadContext loaded curchain),locals) = do
-	e <- resolveNames (se,sp) (Set.fromList [])
+	e <- mResolveNames modname (se,sp) revimports loaded locals (Set.fromList [])
 	let (name2,locals2) = case vis of
-		SVLocal -> (getLocalName name,(Set.insert name locals))
+		SVLocal -> (getLocalName modname name,(Set.insert name locals))
 		SVGlobal -> (modname++"."++name,(Set.delete name locals))
 	let loaded2 = Set.insert name2 loaded
 	return$(MLoadContext (loaded2) ((name2,e):curchain),locals2)
-	where
-		getLocalName a = " "++modname++"."++a
-		resolveNames :: (SSExp,SPosition) -> (Set.Set [Char]) -> MMayFail LExpr
-		resolveNames (e,p) c = case e of
-			(SSInt a) -> return (LInt a)
-			(SSDouble a) -> return (LDouble a)
-			(SSLambda a (e1,p1)) -> do
-				e2 <- resolveNames (e1,p1) (Set.insert a c)
-				return (LAbs a e2)
-			(SSRef a)
-				| (Set.member a c) -> return$LRef a
-				| (Set.member a loaded) -> return$LRef a
-				| (Set.member a locals) -> return$LRef$getLocalName a
-				| (Set.member (modname++"."++a) loaded) -> return$LRef$(modname++"."++a)
-				| otherwise -> case (filter (\x -> (Set.member (x++"."++a) loaded)) revimports) of
-					[] -> MFail ("undefined symbol "++a) modname p
-					(x:_) -> return$LRef (x++"."++a)
-			(SSApply (e1,p1) (e2,p2)) -> do
-				re1 <- resolveNames (e1,p1) c
-				re2 <- resolveNames (e2,p2) c
-				return$LApply re1 re2
 mAddDefs :: [Char] -> [[Char]] -> [SSDef] -> MLocalLoadContext -> MMayFail MLocalLoadContext
 mAddDefs modname revimports defs c = case defs of
 	[] -> return c

UParse.hs

@@ -158,26 +158,37 @@ groupStrings = (\x -> (dropWhiteSpace x) >>= groupStrings') where
 		remain <- groupStrings r
 		return (f:remain)
 
-groupTokenTree :: [(SToken,SPosition)] -> SMayFail (STokenTree,SPosition)
-groupTokenTree [] = SFail "empty file" (0,0)
-groupTokenTree a = (groupTokenTree' a) >>= (\(r,remain) -> case remain of
-	[] -> SSucc r
-	((_,p)):_ -> SFail "extra tokens at end of file" p
-	) where
-	groupTokenTree' a = case a of
-		((SLeftPar,p):r) -> do
-			(trees,remain) <- groupUntilRightPar r p
-			if null trees then SFail "empty ()" p else
-				return (((STTList trees),p),remain)
-		((SRightPar,p):r) -> SFail "unmatched )" p
-		((ah,p):r) -> return (((STTNode ah),p),r)
-	groupUntilRightPar a sp = case a of
-		[] -> SFail "unmatched (" sp
-		((SRightPar,_):r) -> return ([],r)
+firstTokenTree :: [(SToken,SPosition)] -> SMayFail ((STokenTree,SPosition),[(SToken,SPosition)])
+firstTokenTree a = case a of
+	((SLeftPar,p):r) -> do
+		(trees,remain) <- groupUntilRightPar r p
+		if null trees then SFail "empty ()" p else
+			return (((STTList trees),p),remain)
+	((SRightPar,p):r) -> SFail "unmatched )" p
+	((ah,p):r) -> return (((STTNode ah),p),r)
+	where
+		groupUntilRightPar a sp = case a of
+			[] -> SFail "unmatched (" sp
+			((SRightPar,_):r) -> return ([],r)
+			_ -> do
+				(t,rr) <- firstTokenTree a
+				(ts,rrr) <- groupUntilRightPar rr sp
+				return ((t:ts),rrr)
+singleTokenTree a = do
+	case a of
+		[] -> SFail "empty line" (0,0)
 		_ -> do
-			(t,rr) <- groupTokenTree' a
-			(ts,rrr) <- groupUntilRightPar rr sp
-			return ((t:ts),rrr)
+			(t,r) <- firstTokenTree a
+			case r of
+				[] -> SSucc t
+				((_,p):r) -> SFail "extra token" p
+groupTokenTree :: [(SToken,SPosition)] -> SMayFail [(STokenTree,SPosition)]
+groupTokenTree a = case a of
+	[] -> SSucc []
+	_ -> do
+		(tt,remain) <- (firstTokenTree a)
+		rt <- groupTokenTree remain
+		return (tt:rt)
 
 parseSSExp :: (STokenTree,SPosition) -> SMayFail (SSExp,SPosition)
 parseSSExp (tree,sp) = case tree of
@@ -234,13 +245,15 @@ parseSSExp (tree,sp) = case tree of
 			return (SSApply (e1,p1) (SSLambda name (e2,p2),p0),p0)
 		constructRunSugar ((_,p1):r) p = SFail "invalid statement in do/run clause" p1
 
-parseSSModule :: (STokenTree,SPosition) -> SMayFail (SSModule,SPosition)
-parseSSModule (STTNode _,p) = SFail "program must start with (" p
-parseSSModule (STTList trees,p) = do
+parseSSModule :: [(STokenTree,SPosition)] -> SMayFail SSModule
+parseSSModule trees = do
 	(simports,others1) <- getImportBlock trees
 	(sdefs,others2) <- getDefBlock others1
 	(case others2 of
-		[] -> SSucc ((SSModule simports sdefs),p)
+		[] -> return (SSModule simports sdefs)
+		((e,p):[]) -> do
+			(e1,p1) <- parseSSExp (e,p)
+			return (SSModule simports (sdefs++[((SSDef "main" (e1,p1) SVGlobal),p)]))
 		r -> SFail ("illegal declaration") (snd (head r))
 		) where
 		getImportBlock blocks = case blocks of
@@ -272,5 +285,6 @@ extractLExpr s = case s of
 	(SSRef v) -> LRef v
 	(SSApply (v1,_) (v2,_)) -> LApply (extractLExpr v1) (extractLExpr v2)
 
-parseLExprStr a = (groupStrings $ annotatePositions a) >>= groupTokenTree >>= parseSSExp >>= (return . extractLExpr.fst)
-parseSSModuleStr a = (groupStrings $ annotatePositions a) >>= groupTokenTree >>= parseSSModule >>= (return . fst)
+parseSTokenTreeStr a = (groupStrings $ annotatePositions a) >>= singleTokenTree
+parseLExprStr a = parseSTokenTreeStr a >>= parseSSExp >>= (return . extractLExpr.fst)
+parseSSModuleStr a = (groupStrings $ annotatePositions a) >>= groupTokenTree >>= parseSSModule