1 files changed, 99 insertions, 0 deletions
diff --git a/src/SPL/Parse.hs b/src/SPL/Parse.hs
new file mode 100644
index 0000000..afac84a
--- /dev/null
+++ b/src/SPL/Parse.hs
@@ -0,0 +1,99 @@
+-- vim: et ts=2 sw=2 ai:
+{-# LANGUAGE LambdaCase #-}
+module SPL.Parse (parse)
+where
+
+import Text.Parsec (sepBy)
+import qualified Text.Parsec
+
+import Control.Applicative
+import Data.Functor
+
+import SPL.Syntax hiding (TInt,TBool,TChar,TArrow)
+import qualified SPL.Syntax
+import SPL.Lex
+
+type Parser t = Text.Parsec.Parsec [Token] () t
+
+satisfy :: (Token -> Bool) -> Parser Token
+satisfy p = Text.Parsec.tokenPrim
+  show
+  (const . const)
+  (\t -> if p t then Just t else Nothing)
+
+token :: Token -> Parser Token
+token = satisfy . (==)
+
+check :: (Token -> Maybe a) -> Parser a
+check f = Text.Parsec.tokenPrim
+  show
+  (const . const)
+  f
+
+parse :: [Token] -> Either Text.Parsec.ParseError Program
+parse = Text.Parsec.parse spl "Not a valid program" . filter (not . isCommentToken)
+
+spl :: Parser Program
+spl = collect <$> (many toplevel <* Text.Parsec.eof)
+  where
+    collect :: [Either Variable Function] -> Program
+    collect vfs = Program [f | Right f <- vfs] [v | Left v <- vfs]
+
+toplevel :: Parser (Either Variable Function)
+toplevel = Left <$> var <|> Right <$> fun
+
+comment :: Parser String
+comment = toString <$> satisfy isCommentToken
+  where
+    toString (TSingleComment s) = s
+    toString (TBlockComment s)  = s
+
+var :: Parser Variable
+var = do
+  t  <- Just <$> plainType <|> (token TVar $> Nothing)
+  id <- ident
+  token TEquals
+  val <- expr
+  token TSemicolon
+  return $ Variable id t val
+
+fun :: Parser Function
+fun = do
+  id <- ident
+  token TParenOpen
+  args <- ident `sepBy` token TComma
+  token TParenClose
+  ftype <- optional (token TColonColon *> funType)
+  token TBraceOpen
+  vars <- many var
+  stmt <- statement
+  token TBraceClose
+  return $ Function id ftype args vars stmt
+
+ident :: Parser Name
+ident = (\(TIdent id) -> id) <$> satisfy isIdentToken
+
+funType :: Parser Type
+funType = do
+  argtypes <- many plainType
+  token TArrow
+  rettype <- plainType
+  return $ SPL.Syntax.TArrow argtypes rettype
+
+plainType :: Parser Type
+plainType = -- TODO
+  token TIntType  $> SPL.Syntax.TInt  <|>
+  token TBoolType $> SPL.Syntax.TBool <|>
+  token TCharType $> SPL.Syntax.TChar
+
+expr :: Parser Expression
+expr = literal -- TODO
+  where
+    literal :: Parser Expression
+    literal = fmap Literal $ check $ \case
+      TInt i  -> Just (LInt i)
+      TBool b -> Just (LBool b)
+      _       -> Nothing
+
+statement :: Parser Statement
+statement = fail "" -- TODO