add basic parser and repl

UData.hs

@@ -7,11 +7,40 @@ data BFunc = BArithFunc BArith | BArith2Func BBinaryArith  deriving Show
 data BValue = BNumVal BNum | BFuncVal BFunc | BIntList [Int]  deriving Show
 data BResult = BClean BValue | BException [Char] deriving Show
 
+showBNum :: BNum -> [Char]
+showBNum (BInt v) = show v
+showBNum (BFloat v) = show v
+
+showBBinaryArith :: BBinaryArith -> [Char]
+showBBinaryArith BAdd = "+"
+showBBinaryArith BSub = "-"
+showBBinaryArith BMul = "*"
+showBBinaryArith BDiv = "/"
+showBBinaryArith BMod = "%"
+
+showBFunc :: BFunc -> [Char]
+showBFunc (BArithFunc (BArith2 b v)) = "("++(showBBinaryArith b)++" "++(showBNum v)++")"
+showBFunc (BArithFunc BToInt) = "toInt"
+showBFunc (BArithFunc BToFloat) = "toFloat"
+showBFunc (BArith2Func b) = showBBinaryArith b
+
+showBValue :: BValue -> [Char]
+showBValue (BNumVal v) = showBNum v
+showBValue (BFuncVal v) = showBFunc v
+showBValue (BIntList v) = "(fileName (list"++(concat $ map (\x -> (' ':(show x))) v)++"))" where
+
 numToBResult :: BNum -> BResult
 numToBResult a = BClean (BNumVal a)
 
 data BCompType = BLe | BGe | BNLe | BNGe | BEq | BNEq deriving Show
 
+showBCompType BLe = "<"
+showBCompType BGe = ">"
+showBCompType BNLe = ">="
+showBCompType BNGe = "<="
+showBCompType BEq = "=="
+showBCompType BNEq = "/="
+
 applyBVal :: BValue -> BValue -> BResult
 applyBVal (BFuncVal b) (BNumVal v) = applyBFunc b v
 applyBVal (BFuncVal b) _ = BException ("cannot apply non-numeric argument to builtin function "++(show b))

UEnvironment.hs

@@ -5,11 +5,10 @@ import System.Environment
 import Data.Char
 import qualified Data.Map as Map
 
-
-
 class UEnv e where
 	eExit :: Int -> e ()
 	eException :: [Char] -> e ()
+	eReturnResult :: [Char] -> e ()
 	eOpen :: [Int] -> Int -> e Int
 	eClose :: Int -> e Int
 	eGetChar :: Int -> e Int
@@ -20,7 +19,7 @@ class UEnv e where
 efOpenModes = [ReadMode,WriteMode,AppendMode,ReadWriteMode]
 -- currently, only r and w are supported
 
-data UFinishState a = URunning a | UFinished Int | UExceptionHappened [Char] deriving Show
+data UFinishState a = URunning a | UFinished Int | UExceptionHappened [Char] | UResultReturned [Char] deriving Show
 data UFileList h = UFileList {flFiles::[Maybe h],flArgToRead::[Int]} deriving Show
 
 flAddHandle :: h -> UFileList h -> (Int,UFileList h)
@@ -52,6 +51,7 @@ instance Monad URealWorldEnv where
 				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
 			)
 		)
@@ -66,6 +66,8 @@ instance UEnv URealWorldEnv where
 		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)
@@ -126,6 +128,7 @@ runRealWorld a = (runRealWorldEnv (initRealWorldEnv >> a) (UFileList [] [])) >>=
 		case exitstate of
 			UFinished 0 -> return ()
 			UFinished a -> putStrLn ("exit with code "++show a)
-			UExceptionHappened e -> putStrLn e
+			UExceptionHappened e -> putStrLn ("Exception: " ++ e)
+			UResultReturned e -> putStrLn e
 			URunning _ -> putStrLn "execution interupted"
 	)

ULambdaExpression.hs

@@ -0,0 +1,3 @@
+module ULambdaExpression where
+
+data LExpr = LInt Int | LDouble Double | LRef [Char] | LAbs [Char] LExpr | LApply LExpr LExpr deriving Show

UParse.hs

@@ -1,10 +1,11 @@
 module UParse where
 
 import Data.Char
+import ULambdaExpression
 
 type SPosition = (Int,Int)
 data SMayFail a = SFail [Char] SPosition | SSucc a deriving Show
-data SToken = STAtom [Char] | STInt Int | STDouble Double | SLeftPar | SRightPar | STLambda | STStr deriving Show
+data SToken = STAtom [Char] | STInt Int | STDouble Double | SLeftPar | SRightPar | STLambda | STStr [Char] deriving Show
 data STokenTree = STTNode SToken | STTList [(STokenTree,SPosition)]
 
 instance Show STokenTree where
@@ -13,10 +14,22 @@ instance Show STokenTree where
 			STTNode token -> take indent (repeat ' ') ++ ((show token) ++" ;"++(show pos)++ "\n")
 			STTList trees -> ((take indent (repeat ' '))++"STTree ;"++(show pos)++"\n")++concat (map (\(x,p) -> show' x (indent+4) p) trees)
 
-data SSExp = SSInt Int | SSDouble Double | SSLambda [Char] (SSExp,SPosition) | SSRef [Char] | SSApply (SSExp,SPosition) (SSExp,SPosition) deriving Show
-data SSImport = SSImport [Char] Bool deriving Show
-data SSDef = SSDef [Char] (SSExp,SPosition) Bool deriving Show
-data SSModule = SSMainModule [(SSImport,SPosition)] [(SSDef,SPosition)] (SSExp,SPosition) | SSSubModule [Char] [(SSImport,SPosition)] [(SSDef,SPosition)] deriving Show
+data SSExp = SSInt Int | SSDouble Double | SSLambda [Char] (SSExp,SPosition) | SSRef [Char] | SSApply (SSExp,SPosition) (SSExp,SPosition)
+data SVisibility = SVLocal | SVGlobal deriving Show
+data SImportMode = SIQualified | SIUnqualified deriving Show
+data SSImport = SSImport [Char] SImportMode deriving Show
+data SSDef = SSDef [Char] (SSExp,SPosition) SVisibility deriving Show
+data SSModule = SSModule [(SSImport,SPosition)] [(SSDef,SPosition)] deriving Show
+
+instance Show SSExp where
+	show t = show' t 0 (0,0) where
+		show' t indent pos = case t of
+			SSInt val -> ((show val) ++" #|"++(show pos)++"|#")
+			SSDouble val -> ((show val) ++" #|"++(show pos)++"|#")
+			SSRef name -> (name ++" #|"++(show pos)++"|#")
+			SSLambda name (e,p) -> ("(\\"++name ++" ;"++(show pos)++ "\n" ++ (take indent (repeat ' ')) ++ show' e (indent+4) p ++(take indent (repeat ' '))++")")
+			SSApply (e1,p1) (e2,p2) -> ("("++ show' e1 (indent+4) p1 ++ "\n" ++ (take indent (repeat ' '))++show' e2 (indent+4) p2++")")
+
 
 instance Monad SMayFail where
 	(SSucc a) >>= g = g a
@@ -27,12 +40,17 @@ annotatePositions :: [Char] -> [(Char,SPosition)]
 annotatePositions content = zip content (scanl (\(l0,c0) c -> 
 	if c=='\n' then (l0+1,0) else (l0,c0+1)) (0,0) content)
 
-dropWhiteSpace :: [(Char,SPosition)] -> [(Char,SPosition)]
-dropWhiteSpace [] = []
+dropWhiteSpace :: [(Char,SPosition)] -> SMayFail [(Char,SPosition)]
+dropWhiteSpace [] = return []
 dropWhiteSpace ((a,ap):ar)
 	| isSpace a = dropWhiteSpace ar
 	| a==';' = dropWhiteSpace (dropWhile (\(b,_) -> b/='\n') ar)
-	| otherwise = ((a,ap):ar)
+	| a=='#' && not (null ar) && (fst (head ar))=='|' = waitUntilClose (tail ar) ap
+	| otherwise = return ((a,ap):ar) where
+		waitUntilClose [] ap = SFail "unclosed block comment" ap
+		waitUntilClose (_:[]) ap = SFail "unclosed block comment" ap
+		waitUntilClose (('|',_):('#',_):arr) ap = dropWhiteSpace arr
+		waitUntilClose (_:arr) ap = waitUntilClose arr ap
 
 isValidCharInt :: Int -> Bool
 isValidCharInt a = (a>=0 && a<1114112)
@@ -65,14 +83,14 @@ splitChrSpecial ar ap = case ar of
 	((c,_):arr) -> SSucc (c,arr)
 splitStrLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)])
 splitStrLiteral ar ap = case ar of
-	('"',_):arr -> SSucc ((STAtom "",ap),arr)
+	('"',_):arr -> SSucc ((STStr "",ap),arr)
 	('\\',arp):arr -> do
 		(c,arrr) <- splitChrSpecial arr arp
-		(((STAtom sr),_),arrrr) <- splitStrLiteral arrr ap
-		return ((STAtom (c:sr),ap),arrrr)
+		(((STStr sr),_),arrrr) <- splitStrLiteral arrr ap
+		return ((STStr (c:sr),ap),arrrr)
 	(ah,_):arr -> do
-		(((STAtom sr),_),arrr) <- splitStrLiteral arr ap
-		return ((STAtom (ah : sr),ap),arrr)
+		(((STStr sr),_),arrr) <- splitStrLiteral arr ap
+		return ((STStr (ah : sr),ap),arrr)
 	[] -> SFail "unmatched \"" ap
 splitCharLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)])
 splitCharLiteral ar ap = case ar of
@@ -83,7 +101,7 @@ splitCharLiteral ar ap = case ar of
 			('\'',_):arrr -> SSucc (((STInt (ord c)),ap),arrr)
 			_ -> SFail "unmatched \'" ap
 	(c0,_):('\'',_):arr -> SSucc (((STInt (ord c0)),ap),arr)
-	[] -> SFail "unmatched \"" ap
+	_ -> SFail "unmatched \'" ap
 
 isStopChar c = isSpace c || elem c "()\\;"
 splitNumLiteral :: [(Char,SPosition)] -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) 
@@ -133,7 +151,7 @@ splitFirstString ((a,ap):ar)
 	| otherwise = (let (al,arr) =span (\(x,_) -> not (isStopChar x)) ((a,ap):ar) in
 		SSucc ((STAtom (map fst al),ap),arr))
 groupStrings :: [(Char,SPosition)] -> SMayFail [(SToken,SPosition)] 
-groupStrings = groupStrings' . dropWhiteSpace where
+groupStrings = (\x -> (dropWhiteSpace x) >>= groupStrings') where
 	groupStrings' [] = SSucc []
 	groupStrings' a = do
 		(f,r) <- splitFirstString a
@@ -160,3 +178,82 @@ groupTokenTree a = (groupTokenTree' a) >>= (\(r,remain) -> case remain of
 			(t,rr) <- groupTokenTree' a
 			(ts,rrr) <- groupUntilRightPar rr sp
 			return ((t:ts),rrr)
+
+parseSSExp :: (STokenTree,SPosition) -> SMayFail (SSExp,SPosition)
+parseSSExp (tree,sp) = case tree of
+	STTNode (STAtom name) -> return (SSRef name,sp)
+	STTNode (STInt val) -> return (SSInt val,sp)
+	STTNode (STDouble val) -> return (SSDouble val,sp)
+	STTNode (STStr val) -> return (constructStrSugar val sp)
+	STTNode _ -> SFail "illegal token " sp
+	STTList (((STTNode STLambda),p):r) -> constructLambdaSugar r p
+	STTList (((STTNode (STAtom "lambda")),p):r) -> constructLambdaSugar r p
+	STTList (((STTNode (STAtom "list")),p):[]) -> SFail "list expression must not be empty" p
+	STTList (((STTNode (STAtom "list")),p):r) -> constructListSugar r p
+	STTList [] -> SFail "empty expression" sp
+	STTList (_:[]) -> SFail "extra parenthesis" sp
+	STTList (f:r) -> do
+		(e1,p1) <- parseSSExp f
+		constructApplySugar r (e1,p1)
+	where
+		constructStrSugar [] sp = ((SSRef "empty"),sp)
+		constructStrSugar (a:ar) sp = ((SSApply (SSApply (SSRef "cons",sp) ((SSInt (ord a)),sp),sp) (constructStrSugar ar sp)),sp)
+		constructLambdaSugar [] p = SFail "incomplete lambda expression" p
+		constructLambdaSugar (_:[]) p = SFail "incomplete lambda expression" p
+		constructLambdaSugar ((STTNode (STAtom name),p1):body:[]) p = do
+			(ebody,pb) <- parseSSExp body
+			return ((SSLambda name (ebody,pb)),p1)
+		constructLambdaSugar ((_,p1):_:[]) p = SFail "lambda expression needs a variable name" p1
+		constructLambdaSugar ((STTNode (STAtom name),p1):r) p = do
+			(ebody,pb) <- constructLambdaSugar r p
+			return ((SSLambda name (ebody,pb)),p1)
+		constructLambdaSugar ((_,p1):_) p = SFail "lambda expression needs a variable name" p1
+		constructListSugar [] p = return ((SSRef "empty"),p)
+		constructListSugar (f:r) p = do
+			(e1,p1) <- parseSSExp f
+			(remain,p2) <- constructListSugar r p
+			return ((SSApply ((SSApply ((SSRef "cons"),p1) (e1,p1)),p1) (remain,p2)),p1)
+		constructApplySugar [] (e,p) = SSucc (e,p)
+		constructApplySugar (f:r) (e,p) = do
+			(e1,p1) <- parseSSExp f
+			constructApplySugar r ((SSApply (e,p) (e1,p1)),p)
+
+parseSSModule :: (STokenTree,SPosition) -> SMayFail (SSModule,SPosition)
+parseSSModule (STTNode _,p) = SFail "program must start with (" p
+parseSSModule (STTList trees,p) = do
+	(simports,others1) <- getImportBlock trees
+	(sdefs,others2) <- getDefBlock others1
+	(case others2 of
+		[] -> SSucc ((SSModule simports sdefs),p)
+		r -> SFail ("illegal declaration "++(show r)) (snd (head r))
+		) where
+		getImportBlock blocks = case blocks of
+			[] -> SSucc ([],[])
+			((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
+				(sis,remain) <- getImportBlock r
+				return ((((SSImport name SIQualified),p1):sis),remain)
+			_ -> SSucc ([],blocks)
+		getDefBlock blocks = case blocks of
+			[] -> SSucc ([],[])
+			((STTList [(STTNode (STAtom "def"),_),(STTNode (STAtom name),_),body]),p1):r -> do 
+				(firstexp,p2) <- parseSSExp body
+				(sds,remain) <- getDefBlock r
+				return ((((SSDef name (firstexp,p2) SVGlobal),p1):sds),remain)
+			((STTList [(STTNode (STAtom "let"),_),(STTNode (STAtom name),_),body]),p1):r -> do 
+				(firstexp,p2) <- parseSSExp body
+				(sds,remain) <- getDefBlock r
+				return ((((SSDef name (firstexp,p2) SVLocal),p1):sds),remain)
+			_ -> SSucc ([],blocks)
+
+extractLExpr :: SSExp -> LExpr
+extractLExpr s = case s of
+	(SSInt v) -> LInt v
+	(SSDouble v) -> LDouble v
+	(SSLambda a (v,_)) -> LAbs a (extractLExpr v)
+	(SSRef v) -> LRef v
+	(SSApply (v1,_) (v2,_)) -> LApply (extractLExpr v1) (extractLExpr v2)
+
+parseLExprStr a = (groupStrings $ annotatePositions a) >>= groupTokenTree >>= parseSSExp >>= (return . extractLExpr.fst)

URunTime.hs

@@ -3,6 +3,7 @@ module URunTime where
 import qualified Data.Map as Map
 import UData
 import UEnvironment
+import ULambdaExpression
 
 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
@@ -12,6 +13,43 @@ type VContext=Map.Map [Char] VResult
 type BoundValue = (Value,VContext)
 data VResult = VGood BoundValue | VException [Char] deriving Show
 
+showVComp (VComp b) = showBCompType b
+showVComp (VComp1 b v) = "("++(showBCompType b)++" "++(showBNum v)++")"
+
+showVSysCall VExit = "exit"
+showVSysCall (VExit1 v) = "(exit "++(show v)++")"
+showVSysCall VOpen = "open"
+showVSysCall (VOpen1 v) = "(open "++(showBValue (BIntList v))++")"
+showVSysCall (VOpen2 v a) = "(open "++(showBValue (BIntList v))++" "++(show a)++")"
+showVSysCall (VOpen3 v a _) = "(open "++(showBValue (BIntList v))++" "++(show a)++" ...)"
+showVSysCall VClose = "close"
+showVSysCall (VClose1 v) = "(close "++(show v)++")"
+showVSysCall (VClose2 v _) = "(close "++(show v)++" ...)"
+showVSysCall VGetChar = "getChar"
+showVSysCall (VGetChar1 v) = "(getChar "++(show v)++")"
+showVSysCall (VGetChar2 v _) = "(getChar "++(show v)++" ...)"
+showVSysCall VPeekChar = "peekChar"
+showVSysCall (VPeekChar1 v) = "(peekChar "++(show v)++")"
+showVSysCall (VPeekChar2 v _) = "(peekChar "++(show v)++" ...)"
+showVSysCall VPutChar = "putChar"
+showVSysCall (VPutChar1 v) = "(putChar "++(show v)++")"
+showVSysCall (VPutChar2 v a) = "(putChar "++(show v)++" "++(show a)++")"
+showVSysCall (VPutChar3 v a _) = "(putChar "++(show v)++" "++(show a)++" ...)"
+showVSysCall (VGetArg) = "getArg"
+showVSysCall (VGetArg1 _) = "(getArg ...)"
+
+showValue :: Value -> [Char]
+showValue (VBuiltin b) = showBValue b
+showValue (VAbs name e) = "(\\"++name++" "++(showVExpression e)++")"
+showValue (VCompFunc v) = showVComp v
+showValue (VSys v) = showVSysCall v
+
+showVExpression :: VExpression -> [Char]
+showVExpression e = case e of
+	(VRef v) -> v
+	(VApply v1 v2) -> "("++(showVExpression v1)++" "++(showVExpression v2)++")"
+	(VClean v) -> showValue v
+
 veAbs a b = VClean (VAbs a b)
 
 vTrue = VAbs "x" (veAbs "y" (VRef "x"))
@@ -27,14 +65,16 @@ boolValue True = vTrue
 boolValue False = vTrue
 
 veInt a=VClean (VBuiltin (BNumVal (BInt a)))
-veFloat a=VClean (VBuiltin (BNumVal (BFloat a)))
+veDouble a=VClean (VBuiltin (BNumVal (BFloat a)))
 
 vBuiltInList=[
 	("+", (VBuiltin (BFuncVal (BArith2Func BAdd)))),
 	("-", (VBuiltin (BFuncVal (BArith2Func BSub)))),
 	("*", (VBuiltin (BFuncVal (BArith2Func BMul)))),
 	("/", (VBuiltin (BFuncVal (BArith2Func BDiv)))),
 	("%", (VBuiltin (BFuncVal (BArith2Func BMod)))),
+	("toInt", (VBuiltin (BFuncVal (BArithFunc BToInt)))),
+	("toFloat", (VBuiltin (BFuncVal (BArithFunc BToFloat)))),
 	("<", (VCompFunc (VComp BLe))),
 	(">=", (VCompFunc (VComp BNLe))),
 	(">", (VCompFunc (VComp BGe))),
@@ -50,8 +90,8 @@ vBuiltInList=[
 	("peekCharF", (VSys (VPeekChar))),
 	("putChar", (VSys (VPutChar1 1))),
 	("putCharF", (VSys (VPutChar))),
-	("getArgs", (VSys (VGetArg))),
-	("makeIntList", (VBuiltin (BIntList [])))
+	("getArg", (VSys (VGetArg))),
+	("consFileName", (VBuiltin (BIntList [])))
 	]
 
 emptyContext = (Map.empty::VContext)
@@ -63,6 +103,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 _) -> VException ("cannot feed non-builtin value to builtin value "++(show a))
 	)where
 		bValToVResult (BException e) = VException e
 		bValToVResult (BClean v) = VGood (VBuiltin v,emptyContext)
@@ -82,7 +123,7 @@ applyFunc (VSys VExit,_) br = case br of
 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 (reverse b)),emptyContext)
+						(VGood ((VBuiltin (BIntList b)),_)) -> VGood (VSys (VOpen1 b),emptyContext)
 						_                                   -> VException "cannot call Open with non-IntList filename"
 applyFunc (VSys (VOpen1 a),_) br = case br of
 						(VException e)                      -> VException e
@@ -146,8 +187,17 @@ executeVResult vr = case vr of
 		(VSys (VGetChar2 f cont)) -> (eGetChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
 		(VSys (VPeekChar2 f cont)) -> (ePeekChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
 		(VSys (VGetArg1 cont)) -> eGetArg >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
-		(VSys _) -> eException "insufficient syscall args"
-		_ -> eException "expression not evaluated to a syscall"
+		(VSys s) -> eException ("insufficient syscall args in "++(show s))
+		r -> eReturnResult (showValue r)
+		-- r -> eException "evaluated to non-builtin type"
 		)
 executeVExp :: (UEnv e) => (Monad e) => VExpression -> e()
 executeVExp exp = executeVResult (evalExp exp vrBuiltInDict)
+
+fromLExpr :: LExpr -> VExpression
+fromLExpr l = case l of
+	LInt v -> veInt v
+	LDouble v -> veDouble v
+	LRef v -> VRef v
+	LAbs a v -> veAbs a (fromLExpr v)
+	LApply a b -> VApply (fromLExpr a) (fromLExpr b)