Confusing haskell shenanigans

Functional thinking isn't that easy. Huh.

3 files changed, 126 insertions, 58 deletions

diff --git a/src/Fun/Compiler.hs b/src/Fun/Compiler.hs
index f7e5c85..5ceb967 100644
--- a/src/Fun/Compiler.hs
+++ b/src/Fun/Compiler.hs
@@ -4,14 +4,18 @@ 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
+parse :: String -> Either String Program -- TODO: Should be tree
+parse file = case program file of
+  Left a -> Left $ "Invalid code around here:\n" ++ case a of
+    Nothing  -> "[No context]"
+    Just str -> str
+  Right (a, b) -> Right 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
+    Right file      -> case parse file of
+      Left  err   -> putStrLn err
+      Right block -> putStrLn . show $ block
diff --git a/src/Fun/Parser.hs b/src/Fun/Parser.hs
index f3f5201..1f6be7e 100644
--- a/src/Fun/Parser.hs
+++ b/src/Fun/Parser.hs
@@ -3,11 +3,12 @@ module Fun.Parser where
 import           Data.Char
 import           Fun.Tree
 
-type Parser a = String -> Maybe (a, String)
+type Context = Maybe String
+type Parser a = String -> Either Context (a, String)
 
 char :: Parser Char
-char []       = Nothing
-char (x : xs) = Just (x, xs)
+char []       = Left Nothing
+char (x : xs) = Right (x, xs)
 
 digit :: Parser Char
 digit = char <=> isDigit
@@ -41,11 +42,14 @@ letters = iter letter
 alphanum :: Parser Char
 alphanum = digit <|> letter
 
+string :: Parser String
+string = literal '"' <-+> iter (char <=> (/= '"')) <+-> literal '"'
+
 literal :: Char -> Parser Char
 literal c = char <=> (== c)
 
 result :: a -> Parser a
-result a cs = Just (a, cs)
+result a cs = Right (a, cs)
 
 iter :: Parser Char -> Parser String
 iter m = (iterS m) <=> (/= "")
@@ -53,6 +57,9 @@ iter m = (iterS m) <=> (/= "")
 iterS :: Parser a -> Parser [a]
 iterS m = m <+> iterS m >>> (\(x, y) -> x : y) <|> result []
 
+iterFail :: Parser a -> Parser [a]
+iterFail m = m <+> iterFail m >>> (\(x, y) -> x : y)
+
 token :: Parser a -> Parser a
 token = (<+-> iterS space)
 
@@ -68,77 +75,78 @@ accept w = token ((iter notSpace) <=> (== w))
 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
-
+  Left  a         -> Left a
+  Right (a, rest) -> if (predicate a)
+    then Right (a, rest)
+    else Left $ Just (head . lines $ input)
 
 -- 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)
+  Left  a                    -> Left a
+  Right (resultA, remainder) -> case parserB remainder of
+    Left  a             -> Left a
+    Right (resultB, cs) -> Right ((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)
+  Left  a                    -> Left a
+  Right (resultA, remainder) -> case parserB remainder of
+    Left  a       -> Left a
+    Right (_, cs) -> Right (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)
+  Left  a                    -> Left a
+  Right (resultA, remainder) -> case parserB remainder of
+    Left  a             -> Left a
+    Right (resultB, cs) -> Right (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)
+  Left  a                    -> Left a
+  Right (resultA, remainder) -> Right ((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
+  Left  a       -> Left a
+  Right (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
+  Left _ -> parserB input
+  result -> result
 
 ----
 
 tree :: Parser Tree
-tree = iterS program >>> Tree
+tree = iterFail program >>> Tree
 
 program :: Parser Program
-program = iterS block >>> Program
+program = iterFail block >>> Program
 
 block :: Parser Block
 block = functionBlock <+-> newline >>> Block
 
-visibility :: Parser Char
-visibility = literal '+' <|> literal '-'
+visibility :: Parser Visibility
+visibility =
+  (literal '+' >>> const PublicVisibility)
+    <|> (literal '-' >>> const PrivateVisibility)
 
 functionBlock :: Parser FunctionBlock
-functionBlock =
-  functionDeclaration
-    <+> iterS functionDefinition
-    >>> (\(a, b) -> FunctionBlock a b)
+functionBlock = functionDeclaration <+> iterS functionDefinition >>> build
+  where build (decl, defn) = FunctionBlock decl defn
 
 functionDeclaration :: Parser FunctionDeclaration
 functionDeclaration =
@@ -148,9 +156,10 @@ functionDeclarationWithoutFlags :: Parser FunctionDeclaration
 functionDeclarationWithoutFlags =
   functionName
     <+>  functionDeclarationDelimiter
-    <+>  iterS functionType
+    <+>  functionTypeList
     <+-> newline
-    >>>  (\((a, b), c) -> FunctionDeclarationWithoutFlags a b c)
+    >>>  build
+  where build ((name, vis), types) = FunctionDeclaration name vis types []
 
 functionDeclarationWithFlags :: Parser FunctionDeclaration
 functionDeclarationWithFlags =
@@ -160,33 +169,74 @@ functionDeclarationWithFlags =
     <+-> space
     <+-> literal '%'
     <+-> space
-    <+>  iterS functionFlag
+    <+>  functionFlagList
     <+-> newline
-    >>>  (\(((a, b), c), d) -> FunctionDeclarationWithFlags a b c d)
+    >>>  build
+ where
+  build (((name, vis), types), flags) =
+    FunctionDeclaration name vis types flags
 
-functionDeclarationDelimiter :: Parser Char
+functionDeclarationDelimiter :: Parser Visibility
 functionDeclarationDelimiter =
   space <-+> literal ':' <-+> visibility <+-> literal ':' <+-> space
 
-functionName :: Parser String
-functionName = letter <+> iterS alphanum >>> (\(a, b) -> a : b)
+functionName :: Parser String -- TODO
+functionName = letter <+> iterS alphanum >>> build where build (a, b) = a : b
 
 functionTypeList :: Parser [String]
 functionTypeList =
-  iterS ((functionType <+-> space <+-> literal ':' <+-> space) <|> functionType)
+  (iterS (functionType <+-> space <+-> literal ':' <+-> space))
+    <+> functionType
+    >>> build
+  where build (a, b) = a ++ [b]
+
+functionType :: Parser String -- TODO
+functionType = letter <+> iterS alphanum >>> build where build (a, b) = a : b
 
-functionType :: Parser String
-functionType = letter <+> iterS alphanum >>> (\(a, b) -> a : b)
+functionFlagList :: Parser [String]
+functionFlagList = (iterS (functionFlag <+-> space)) <+> functionFlag >>> build
+  where build (a, b) = a ++ [b]
+
+functionFlags :: [String]
+functionFlags = ["inline", "deprecated"]
 
 functionFlag :: Parser String
-functionFlag = letters
+functionFlag = letters <=> (`elem` functionFlags)
 
 functionDefinition :: Parser FunctionDefinition
 functionDefinition =
-  letters
-    <+-> space
-    <+-> literal ':'
-    <+-> space
-    <+>  letters
-    <+-> newline
-    >>>  (\(a, b) -> FunctionDefinition a b)
+  functionPattern <+-> literal ':' <+-> space <+> functionBody >>> build
+  where build (pattern, body) = FunctionDefinition pattern body
+
+functionPattern :: Parser FunctionPattern
+functionPattern = iterS (functionPatternElement <+-> space) >>> FunctionPattern
+
+functionPatternElement :: Parser FunctionPatternElement
+functionPatternElement =
+  (functionParameter >>> FunctionPatternParameter)
+    <|> (literal '_' >>> const Wildcard)
+    <|> (number >>> FunctionPatternNumber)
+    <|> (string >>> FunctionPatternString)
+
+functionParameter :: Parser String -- TODO
+functionParameter = letter <+> iterS alphanum >>> build
+  where build (a, b) = a : b
+
+functionBody :: Parser FunctionBody
+functionBody =
+  (iterS (functionBodyElement <+-> space))
+    <+> (functionBodyElement <+-> newline)
+    >>> build
+    >>> FunctionBody
+  where build (a, b) = a ++ [b]
+
+functionBodyElement :: Parser FunctionBodyElement
+functionBodyElement =
+  statement
+    <|> (functionName >>> FunctionBodyIdentifier)
+    <|> (functionParameter >>> FunctionBodyIdentifier)
+    <|> (string >>> FunctionBodyString)
+    <|> (number >>> FunctionBodyNumber)
+
+statement :: Parser FunctionBodyElement
+statement = accept "if" >>> Statement
diff --git a/src/Fun/Tree.hs b/src/Fun/Tree.hs
index a7709ee..d6cdecd 100644
--- a/src/Fun/Tree.hs
+++ b/src/Fun/Tree.hs
@@ -11,8 +11,22 @@ data Block = Block FunctionBlock -- | Block DataBlock ...
 data FunctionBlock = FunctionBlock FunctionDeclaration [FunctionDefinition]
   deriving Show
 
-data FunctionDeclaration = FunctionDeclarationWithoutFlags String Char [String] | FunctionDeclarationWithFlags String Char [String] [String]
+data Visibility = PublicVisibility | PrivateVisibility
   deriving Show
 
-data FunctionDefinition = FunctionDefinition String String
+data FunctionDeclaration = FunctionDeclaration String
+                                               Visibility
+                                               [String]
+                                               [String]
+  deriving Show
+
+data FunctionDefinition = FunctionDefinition FunctionPattern FunctionBody
+  deriving Show
+data FunctionPattern = FunctionPattern [FunctionPatternElement]
+  deriving Show
+data FunctionPatternElement = FunctionPatternParameter String | FunctionPatternString String | FunctionPatternNumber Integer | Wildcard
+  deriving Show
+data FunctionBody = FunctionBody [FunctionBodyElement]
+  deriving Show
+data FunctionBodyElement = Statement String | FunctionBodyIdentifier String | FunctionBodyParameter String | FunctionBodyString String | FunctionBodyNumber Integer
   deriving Show