Haskell ftw

3 files changed, 227 insertions, 0 deletions

diff --git a/src/Fun/Compiler.hs b/src/Fun/Compiler.hs
new file mode 100644
index 0000000..f7e5c85
--- /dev/null
+++ b/src/Fun/Compiler.hs
@@ -0,0 +1,17 @@
+module Fun.Compiler where
+
+import           Control.Exception
+import           Fun.Parser
+import           Fun.Tree
+
+parse :: String -> Block -- TODO: Should be tree
+parse file = case block file of
+  Nothing     -> error "Invalid program"
+  Just (a, b) -> a
+
+compile :: String -> IO ()
+compile path = do
+  file <- try $ readFile path
+  case file of
+    Left  exception -> print (exception :: IOError)
+    Right file      -> putStrLn . show $ parse file
diff --git a/src/Fun/Parser.hs b/src/Fun/Parser.hs
new file mode 100644
index 0000000..f3f5201
--- /dev/null
+++ b/src/Fun/Parser.hs
@@ -0,0 +1,192 @@
+module Fun.Parser where
+
+import           Data.Char
+import           Fun.Tree
+
+type Parser a = String -> Maybe (a, String)
+
+char :: Parser Char
+char []       = Nothing
+char (x : xs) = Just (x, xs)
+
+digit :: Parser Char
+digit = char <=> isDigit
+
+digits :: Parser String
+digits = iter digit
+
+number :: Parser Integer
+number =
+  literal '-'
+    <-+> digits
+    >>>  (\n -> -1 * (read n :: Integer))
+    <|>  digits
+    >>>  (\n -> read n :: Integer)
+
+space :: Parser Char
+space = char <=> isSpace
+
+newline :: Parser Char
+newline = char <=> (== '\n')
+
+notSpace :: Parser Char
+notSpace = char <=> (not . isSpace)
+
+letter :: Parser Char
+letter = char <=> isAlpha
+
+letters :: Parser String
+letters = iter letter
+
+alphanum :: Parser Char
+alphanum = digit <|> letter
+
+literal :: Char -> Parser Char
+literal c = char <=> (== c)
+
+result :: a -> Parser a
+result a cs = Just (a, cs)
+
+iter :: Parser Char -> Parser String
+iter m = (iterS m) <=> (/= "")
+
+iterS :: Parser a -> Parser [a]
+iterS m = m <+> iterS m >>> (\(x, y) -> x : y) <|> result []
+
+token :: Parser a -> Parser a
+token = (<+-> iterS space)
+
+-- A parser that will accept a given alpha string
+acceptWord :: String -> Parser String
+acceptWord w = token (letters <=> (== w))
+
+-- A parser that will accept a given string
+accept :: String -> Parser String
+accept w = token ((iter notSpace) <=> (== w))
+
+-- Given a parser and a predicate return the parser only if it satisfies the predicate
+infix 7 <=>
+(<=>) :: Parser a -> (a -> Bool) -> Parser a
+(parser <=> predicate) input = case parser input of
+  Nothing        -> Nothing
+  Just (a, rest) -> if (predicate a) then Just (a, rest) else Nothing
+
+
+-- Combine two parser together pairing their results up in a tuple
+infixl 6 <+>
+(<+>) :: Parser a -> Parser b -> Parser (a, b)
+(parserA <+> parserB) input = case parserA input of
+  Nothing                   -> Nothing
+  Just (resultA, remainder) -> case parserB remainder of
+    Nothing            -> Nothing
+    Just (resultB, cs) -> Just ((resultA, resultB), cs)
+
+-- Sequence operator that discards the second result
+infixl 6 <+->
+(<+->) :: Parser a -> Parser b -> Parser a
+(parserA <+-> parserB) input = case parserA input of
+  Nothing                   -> Nothing
+  Just (resultA, remainder) -> case parserB remainder of
+    Nothing      -> Nothing
+    Just (_, cs) -> Just (resultA, cs)
+
+-- Sequence operator that discards the first result
+infixl 6 <-+>
+(<-+>) :: Parser a -> Parser b -> Parser b
+(parserA <-+> parserB) input = case parserA input of
+  Nothing                   -> Nothing
+  Just (resultA, remainder) -> case parserB remainder of
+    Nothing            -> Nothing
+    Just (resultB, cs) -> Just (resultB, cs)
+
+-- Transform a parsers result
+infixl 5 >>>
+(>>>) :: Parser a -> (a -> b) -> Parser b
+(parser >>> transformer) input = case parser input of
+  Nothing                   -> Nothing
+  Just (resultA, remainder) -> Just ((transformer resultA), remainder)
+
+-- Extract a parsers result	
+infix 4 +>
+(+>) :: Parser a -> (a -> Parser b) -> Parser b
+(parser +> function) input = case parser input of
+  Nothing      -> Nothing
+  Just (a, cs) -> function a cs
+
+-- Combine two parsers using a 'or' type operation
+infixl 3 <|>
+(<|>) :: Parser a -> Parser a -> Parser a
+(parserA <|> parserB) input = case parserA input of
+  Nothing -> parserB input
+  result  -> result
+
+----
+
+tree :: Parser Tree
+tree = iterS program >>> Tree
+
+program :: Parser Program
+program = iterS block >>> Program
+
+block :: Parser Block
+block = functionBlock <+-> newline >>> Block
+
+visibility :: Parser Char
+visibility = literal '+' <|> literal '-'
+
+functionBlock :: Parser FunctionBlock
+functionBlock =
+  functionDeclaration
+    <+> iterS functionDefinition
+    >>> (\(a, b) -> FunctionBlock a b)
+
+functionDeclaration :: Parser FunctionDeclaration
+functionDeclaration =
+  functionDeclarationWithoutFlags <|> functionDeclarationWithFlags
+
+functionDeclarationWithoutFlags :: Parser FunctionDeclaration
+functionDeclarationWithoutFlags =
+  functionName
+    <+>  functionDeclarationDelimiter
+    <+>  iterS functionType
+    <+-> newline
+    >>>  (\((a, b), c) -> FunctionDeclarationWithoutFlags a b c)
+
+functionDeclarationWithFlags :: Parser FunctionDeclaration
+functionDeclarationWithFlags =
+  functionName
+    <+>  functionDeclarationDelimiter
+    <+>  functionTypeList
+    <+-> space
+    <+-> literal '%'
+    <+-> space
+    <+>  iterS functionFlag
+    <+-> newline
+    >>>  (\(((a, b), c), d) -> FunctionDeclarationWithFlags a b c d)
+
+functionDeclarationDelimiter :: Parser Char
+functionDeclarationDelimiter =
+  space <-+> literal ':' <-+> visibility <+-> literal ':' <+-> space
+
+functionName :: Parser String
+functionName = letter <+> iterS alphanum >>> (\(a, b) -> a : b)
+
+functionTypeList :: Parser [String]
+functionTypeList =
+  iterS ((functionType <+-> space <+-> literal ':' <+-> space) <|> functionType)
+
+functionType :: Parser String
+functionType = letter <+> iterS alphanum >>> (\(a, b) -> a : b)
+
+functionFlag :: Parser String
+functionFlag = letters
+
+functionDefinition :: Parser FunctionDefinition
+functionDefinition =
+  letters
+    <+-> space
+    <+-> literal ':'
+    <+-> space
+    <+>  letters
+    <+-> newline
+    >>>  (\(a, b) -> FunctionDefinition a b)
diff --git a/src/Fun/Tree.hs b/src/Fun/Tree.hs
new file mode 100644
index 0000000..a7709ee
--- /dev/null
+++ b/src/Fun/Tree.hs
@@ -0,0 +1,18 @@
+module Fun.Tree where
+
+data Tree = Tree [Program]
+  deriving Show
+
+data Program = Program [Block]
+  deriving Show
+
+data Block = Block FunctionBlock -- | Block DataBlock ...
+  deriving Show
+data FunctionBlock = FunctionBlock FunctionDeclaration [FunctionDefinition]
+  deriving Show
+
+data FunctionDeclaration = FunctionDeclarationWithoutFlags String Char [String] | FunctionDeclarationWithFlags String Char [String] [String]
+  deriving Show
+
+data FunctionDefinition = FunctionDefinition String String
+  deriving Show