Error reporting

3 files changed, 134 insertions, 48 deletions

diff --git a/src/Fun/Compiler.hs b/src/Fun/Compiler.hs
index 5ceb967..a8134ed 100644
--- a/src/Fun/Compiler.hs
+++ b/src/Fun/Compiler.hs
@@ -3,12 +3,21 @@ module Fun.Compiler where
 import           Control.Exception
 import           Fun.Parser
 import           Fun.Tree
+import           System.Exit
+import           System.IO
+
+genTrace :: [String] -> String
+genTrace xs =
+  "Trace of expectance: "
+    ++ foldr (\a b -> a ++ if b == "" then b else " -> " ++ b) "" xs
 
 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
+  Left a -> Left $ "Parse fault!\n" ++ case a of
+    State [] Nothing    -> "No context available"
+    State t  Nothing    -> genTrace t
+    State [] (Just str) -> "Around here:\n" ++ str
+    State t  (Just str) -> genTrace t ++ "\nAround here:\n" ++ str
   Right (a, b) -> Right a
 
 compile :: String -> IO ()
@@ -17,5 +26,7 @@ compile path = do
   case file of
     Left  exception -> print (exception :: IOError)
     Right file      -> case parse file of
-      Left  err   -> putStrLn err
+      Left err -> do
+        hPutStrLn stderr err
+        exitWith (ExitFailure 1)
       Right block -> putStrLn . show $ block
diff --git a/src/Fun/Parser.hs b/src/Fun/Parser.hs
index ee2c51e..4519e2f 100644
--- a/src/Fun/Parser.hs
+++ b/src/Fun/Parser.hs
@@ -1,20 +1,46 @@
 module Fun.Parser where
 
-import           Data.Char
 import           Fun.Tree
 
-type Context = Maybe String
-type Parser a = String -> Either Context (a, String)
+data State = State
+  { trace :: [String]
+  , line  :: Maybe String
+  }
+type Parser a = String -> Either State (a, String)
+
+----
+-- I don't use Data.Char because of planned future reimplementation in Fun
+----
+
+lowerAlpha :: [Char]
+lowerAlpha = "abcdefghijklmnopqrstuvwxyzαβγδεζηθικλμνξοπρστυφχψω"
+
+upperAlpha :: [Char]
+upperAlpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ"
+
+isDigit :: Char -> Bool
+isDigit c = elem c "0123456789"
+
+isLower :: Char -> Bool
+isLower c = elem c lowerAlpha
+
+isUpper :: Char -> Bool
+isUpper c = elem c upperAlpha
+
+isAlpha :: Char -> Bool
+isAlpha c = elem c $ lowerAlpha ++ upperAlpha
+
+----
 
 char :: Parser Char
-char []       = Left Nothing
+char []       = Left $ State ["char"] Nothing
 char (x : xs) = Right (x, xs)
 
 digit :: Parser Char
-digit = char <=> isDigit
+digit = char <=> isDigit <?> "digit"
 
 digits :: Parser String
-digits = iter digit
+digits = iter digit <?> "digits"
 
 number :: Parser Integer
 number =
@@ -23,54 +49,50 @@ number =
     >>>  (\n -> -1 * (read n :: Integer))
     <|>  digits
     >>>  (\n -> read n :: Integer)
+    <?>  "number"
 
 space :: Parser Char
-space = char <=> isSpace
+space = char <=> (== ' ') <?> "space"
 
 newline :: Parser Char
-newline = char <=> (== '\n')
+newline = char <=> (== '\n') <?> "newline"
 
 notSpace :: Parser Char
-notSpace = char <=> (not . isSpace)
+notSpace = char <=> (/= ' ') <?> "non-space"
 
 letter :: Parser Char
-letter = char <=> isAlpha
+letter = char <=> isAlpha <?> "letter"
 
 letters :: Parser String
-letters = iter letter
+letters = iter letter <?> "letters"
 
 alphanum :: Parser Char
-alphanum = digit <|> letter
+alphanum = digit <|> letter <?> "letter or digit"
 
 special :: Parser Char
-special = oneOf "+-*/<^>$@#&!?"
-
--- TODO: Higher-order function?
-linkOr :: [Parser Char] -> Parser Char
-linkOr []       = invalid ' '
-linkOr (x : []) = x
-linkOr (x : xs) = x <|> linkOr xs
+special = oneOf "+-*/<^>$@#&!?" <?> "special character"
 
 oneOf :: [Char] -> Parser Char
-oneOf s = linkOr $ map (\c -> (char <=> (== c))) s
+oneOf s = char <=> (`elem` s) <?> "one of"
 
 string :: Parser String
-string = literal '"' <-+> iter (char <=> (/= '"')) <+-> literal '"'
+string =
+  literal '"' <-+> iter (char <=> (/= '"')) <+-> literal '"' <?> "string"
 
 literal :: Char -> Parser Char
-literal c = char <=> (== c)
+literal c = char <=> (== c) <?> "char (" ++ [c] ++ ")"
 
 result :: a -> Parser a
 result a cs = Right (a, cs)
 
 invalid :: a -> Parser a
-invalid a cs = Left $ Just "Invalid"
+invalid a cs = Left $ State ["<unknown>"] $ Just "Invalid"
 
 iter :: Parser Char -> Parser String
-iter m = (iterS m) <=> (/= "")
+iter m = (iterS m) <=> (/= "") <?> "multiple chars"
 
 iterS :: Parser a -> Parser [a]
-iterS m = m <+> iterS m >>> (\(x, y) -> x : y) <|> result []
+iterS m = m <+> iterS m >>> (\(x, y) -> x : y) <|> result [] <?> "multiple"
 
 iterFail :: Parser a -> Parser [a]
 iterFail m = m <+> iterFail m >>> (\(x, y) -> x : y)
@@ -93,7 +115,7 @@ infix 7 <=>
   Left  a         -> Left a
   Right (a, rest) -> if (predicate a)
     then Right (a, rest)
-    else Left $ Just (head . lines $ input)
+    else Left $ State [] $ Just $ head . lines $ input
 
 -- Combine two parser together pairing their results up in a tuple
 infixl 6 <+>
@@ -140,24 +162,37 @@ infix 4 +>
 infixl 3 <|>
 (<|>) :: Parser a -> Parser a -> Parser a
 (parserA <|> parserB) input = case parserA input of
-  Left _ -> parserB input
+  Left (State t _) -> case parserB input of
+    Left (State t' l) -> case (t, t') of
+      (t , []) -> Left (State t l)
+      ([], t') -> Left (State t' l)
+      (t , t') -> Left (State (t ++ ["<OR>"] ++ t') l)
+    Right (result, cs) -> Right (result, cs)
   result -> result
 
+-- Describe a parser with a string for error reporting
+infix 0 <?>
+(<?>) :: Parser a -> String -> Parser a
+(parser <?> string) input = case parser input of
+  Left  (State t l) -> Left $ State ([string] ++ t) l
+  Right a           -> Right a
+
 ----
 
 tree :: Parser Tree
 tree = iterFail program >>> Tree
 
 program :: Parser Program
-program = iterS block >>> Program
+program = iterFail block >>> Program <?> "program"
 
 block :: Parser Block
-block = functionBlock <+-> newline >>> Block
+block = functionBlock <+-> newline >>> Block <?> "block"
 
 visibility :: Parser Visibility
 visibility =
   (literal '+' >>> const PublicVisibility)
     <|> (literal '-' >>> const PrivateVisibility)
+    <?> "visibility"
 
 functionBlock :: Parser FunctionBlock
 functionBlock = functionDeclaration <+> iterS functionDefinition >>> build
@@ -165,7 +200,9 @@ functionBlock = functionDeclaration <+> iterS functionDefinition >>> build
 
 functionDeclaration :: Parser FunctionDeclaration
 functionDeclaration =
-  functionDeclarationWithoutFlags <|> functionDeclarationWithFlags
+  functionDeclarationWithoutFlags
+    <|> functionDeclarationWithFlags
+    <?> "function declaration"
 
 functionDeclarationWithoutFlags :: Parser FunctionDeclaration
 functionDeclarationWithoutFlags =
@@ -174,6 +211,7 @@ functionDeclarationWithoutFlags =
     <+>  functionTypes
     <+-> newline
     >>>  build
+    <?>  "function declaration without flags"
   where build ((name, vis), types) = FunctionDeclaration name vis types []
 
 functionDeclarationWithFlags :: Parser FunctionDeclaration
@@ -182,58 +220,94 @@ functionDeclarationWithFlags =
     <+>  functionDeclarationDelimiter
     <+>  functionTypes
     <+-> space
-    <+-> literal '%'
-    <+>  functionFlags
+    <+-> functionFlagDelimiter
+    <+>  functionFlagList
     >>>  build
+    <?>  "function declaration with flags"
  where
   build (((name, vis), types), flags) =
     FunctionDeclaration name vis types flags
 
 functionDeclarationDelimiter :: Parser Visibility
 functionDeclarationDelimiter =
-  space <-+> literal ':' <-+> visibility <+-> literal ':' <+-> space
+  space
+    <-+> literal ':'
+    <-+> visibility
+    <+-> literal ':'
+    <+-> space
+    <?>  "function declaration delimiter"
 
 functionName :: Parser String
-functionName = (special <|> letter) <+> iterS (special <|> alphanum) >>> build
+functionName =
+  (special <|> letter)
+    <+> iterS (special <|> alphanum)
+    >>> build
+    <?> "function name"
   where build (first, rest) = first : rest
 
 functionTypes :: Parser [String]
 functionTypes =
-  (iterS (functionType <+-> space <+-> literal ':' <+-> space))
+  iterS (functionType <+-> space <+-> functionTypeDelimiter <+-> space)
     <+> functionType
     >>> build
+    <?> "function types"
   where build (a, b) = a ++ [b]
 
 functionType :: Parser String
-functionType = (letter <=> isUpper) <+> iterS alphanum >>> build
+functionType =
+  (letter <=> isUpper) <+> iter alphanum >>> build <?> "function type"
   where build (first, rest) = first : rest
 
-functionFlags :: Parser [FunctionFlag] -- TODO: Fix flags
-functionFlags = iterS (space <-+> letters) <+-> newline >>> build
+functionTypeDelimiter :: Parser Char
+functionTypeDelimiter = literal ':' <?> "function type delimiter"
+
+functionFlagList :: Parser [FunctionFlag]
+functionFlagList =
+  (iterS (space <-+> functionFlag)) <+-> newline >>> build <?> "function flags"
   where build list = map read list
 
+functionFlagDelimiter :: Parser Char
+functionFlagDelimiter = literal '%' <?> "function flag delimiter"
+
+functionFlags :: [String]
+functionFlags = ["inline", "deprecated"]
+
+functionFlag :: Parser String
+functionFlag = letters <=> (`elem` functionFlags) <?> "function flag"
+
 functionDefinition :: Parser FunctionDefinition
 functionDefinition =
-  functionPattern <+-> literal ':' <+> functionBody >>> build
+  (functionPattern <+-> literal ':')
+    <+> functionBody
+    >>> build
+    <?> "function definition"
   where build (pattern, body) = FunctionDefinition pattern body
 
 functionPattern :: Parser FunctionPattern
-functionPattern = iterS (functionPatternElement <+-> space) >>> FunctionPattern
+functionPattern =
+  iterS (functionPatternElement <+-> space)
+    >>> FunctionPattern
+    <?> "function pattern"
 
 functionPatternElement :: Parser FunctionPatternElement
 functionPatternElement =
   (functionParameter >>> FunctionPatternParameter)
-    <|> (literal '_' >>> const Wildcard)
+    <|> (literal '_' >>> const FunctionPatternWildcard)
     <|> (number >>> FunctionPatternNumber)
     <|> (string >>> FunctionPatternString)
+    <?> "function pattern element"
 
 functionParameter :: Parser String
-functionParameter = letter <+> iterS alphanum >>> build
+functionParameter =
+  letters <|> (letter <+> iter alphanum) >>> build <?> "function parameter"
   where build (a, b) = a : b
 
 functionBody :: Parser FunctionBody
 functionBody =
-  iterS (space <-+> functionBodyElement) <+-> newline >>> FunctionBody
+  iterS (space <-+> functionBodyElement)
+    <+-> newline
+    >>>  FunctionBody
+    <?>  "function body"
 
 functionBodyElement :: Parser FunctionBodyElement
 functionBodyElement =
@@ -242,6 +316,7 @@ functionBodyElement =
     <|> (functionParameter >>> FunctionBodyIdentifier)
     <|> (string >>> FunctionBodyString)
     <|> (number >>> FunctionBodyNumber)
+    <?> "function body element"
 
 statement :: Parser FunctionBodyElement --  TODO
 statement = accept "if" >>> Statement
diff --git a/src/Fun/Tree.hs b/src/Fun/Tree.hs
index ce6cf6c..354677d 100644
--- a/src/Fun/Tree.hs
+++ b/src/Fun/Tree.hs
@@ -30,7 +30,7 @@ data FunctionDefinition = FunctionDefinition FunctionPattern FunctionBody
   deriving Show
 data FunctionPattern = FunctionPattern [FunctionPatternElement]
   deriving Show
-data FunctionPatternElement = FunctionPatternParameter String | FunctionPatternString String | FunctionPatternNumber Integer | Wildcard
+data FunctionPatternElement = FunctionPatternParameter String | FunctionPatternString String | FunctionPatternNumber Integer | FunctionPatternWildcard
   deriving Show
 data FunctionBody = FunctionBody [FunctionBodyElement]
   deriving Show