Initial commit

1 files changed, 161 insertions, 0 deletions

diff --git a/Sil/Parse.icl b/Sil/Parse.icl
new file mode 100644
index 0000000..a9d733d
--- /dev/null
+++ b/Sil/Parse.icl
@@ -0,0 +1,161 @@
+implementation module Sil.Parse
+
+import StdBool
+import StdChar
+from StdFunc import o
+import StdInt
+import StdList
+import StdString
+import StdTuple
+
+import Control.Applicative
+import Control.Monad
+import Data.Error
+from Data.Func import $
+import Data.Functor
+import Data.Maybe
+from Text import <+
+
+import GenEq
+
+import Sil.Parse.Parser
+import Sil.Syntax
+import Sil.Util
+
+derive gEq Token, Literal
+instance == Token where == a b = gEq{|*|} a b
+
+instance toString Token
+where
+	toString TParenOpen  = "("
+	toString TParenClose = ")"
+	toString TBraceOpen  = "{"
+	toString TBraceClose = "}"
+	toString TComma      = ","
+	toString TSemicolon  = ";"
+	toString TAssign     = ":="
+	toString (TLit l)    = toString l
+	toString TIf         = "if"
+	toString TWhile      = "while"
+	toString TReturn     = "return"
+	toString (TName s)   = s
+
+instance name Token
+where
+	name (TLit _)  = "literal"
+	name (TName _) = "name"
+	name t         = toString t
+
+instance toString ParseError
+where
+	toString (Invalid loc sym)       = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
+	toString (Expected s)            = "Expected " <+ s <+ "."
+	toString UnknownError            = "Unknown error."
+
+tokenise :: [Char] -> MaybeError ParseError [Token]
+tokenise cs = reverse <$> tks cs []
+where
+	tks :: [Char] [Token] -> MaybeError ParseError [Token]
+	tks [] t = pure t
+	tks ['(':r] t = tks r [TParenOpen :t]
+	tks [')':r] t = tks r [TParenClose:t]
+	tks ['{':r] t = tks r [TBraceOpen :t]
+	tks ['}':r] t = tks r [TBraceClose:t]
+	tks [',':r] t = tks r [TComma     :t]
+	tks [';':r] t = tks r [TSemicolon :t]
+	tks [':':'=':r] t = tks r [TAssign    :t]
+	tks ['i':'f'                :s:r] t | isSpace s = tks r [TIf    :t]
+	tks ['w':'h':'i':'l':'e'    :s:r] t | isSpace s = tks r [TWhile :t]
+	tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
+	tks ['T':'r':'u':'e'        :s:r] t | isSpace s = tks r [TLit $ BLit True:t]
+	tks ['F':'a':'l':'s':'e'    :s:r] t | isSpace s = tks r [TLit $ BLit False:t]
+	tks cs=:[h:_] t
+	| isSpace h          = tks (dropWhile isSpace cs) t
+	| isDigit h          = tks numrest [TLit $ ILit $ toInt $ toString num:t]
+	| not (isNameChar h) = Error $ Invalid "name" h
+	| otherwise          = tks namerest [TName $ toString name:t]
+	where
+		(name,namerest) = span isNameChar cs
+		(num,numrest)   = span isDigit cs
+
+	isNameChar :: (Char -> Bool)
+	isNameChar = isAlpha
+
+parse :: ([Token] -> MaybeError ParseError Program)
+parse = fst o runParser program
+
+program :: Parser Token Program
+program = (\fs -> {p_funs=fs}) <$> some function <* eof
+
+function :: Parser Token Function
+function =
+	type >>= \t ->
+	name >>= \n ->
+	item TParenOpen >>= \_ ->
+	seplist TComma arg >>= \args ->
+	item TParenClose >>= \_ ->
+	item TBraceOpen >>= \_ ->
+	codeblock >>= \cb ->
+	item TBraceClose >>= \_ -> pure
+		{ f_type = t
+		, f_name = n
+		, f_args = args
+		, f_code = cb
+		}
+
+codeblock :: Parser Token CodeBlock
+codeblock = many initialisation >>= \i ->
+	many statement >>= \s ->
+	pure {cb_init=i, cb_content=s}
+
+initialisation :: Parser Token Initialisation
+initialisation =
+	type >>= \t ->
+	name >>= \n ->
+	item TSemicolon >>= \_ ->
+	pure {init_type=t, init_name=n}
+
+statement :: Parser Token Statement
+statement = (declaration
+	<|> liftM Application application
+	<|> return
+/*	<|> if`
+	<|> while*/) <* item TSemicolon
+where
+	declaration :: Parser Token Statement
+	declaration = liftM2 Declaration name (item TAssign *> application)
+
+	application :: Parser Token Application
+	application
+		=   liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
+		<|> liftM Literal literal
+		<|> liftM Name name
+
+	return :: Parser Token Statement
+	return = liftM Return (item TReturn *> optional application)
+
+name :: Parser Token Name
+name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
+where
+	isName (TName _) = True
+	isName _         = False
+
+arg :: Parser Token Arg
+arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
+	<?> Expected "argument"
+
+type :: Parser Token Type
+type
+	=   type "Bool" TBool
+	<|> type "Int"  TInt
+	<|> type "Void" TVoid
+	<?> Expected "type"
+where
+	type s t = item (TName s) *> pure t
+
+literal :: Parser Token Literal
+literal = satisfy isLit >>= \(TLit lit) -> pure lit
+where
+	isLit :: Token -> Bool
+	isLit (TLit _) = True
+	isLit _        = False