Syntax

4 files changed, 71 insertions, 31 deletions

diff --git a/src/Fun/Compiler.hs b/src/Fun/Compiler.hs
index 46cfe13..a118103 100644
--- a/src/Fun/Compiler.hs
+++ b/src/Fun/Compiler.hs
@@ -3,6 +3,7 @@ module Fun.Compiler where
 import           Control.Exception
 import           Fun.Grammar
 import           Fun.Parser
+import           Fun.Syntax
 import           Fun.Tree
 import           System.Exit
 import           System.IO
@@ -17,27 +18,39 @@ traceBranch c (OrTrace t1 t2) =
     ++ (traceTree (c + 2) t2)
 
 traceTree :: Int -> [Trace] -> String -- TODO: Indent/arrow first map
-traceTree c ts = foldr join "" (map (traceBranch c) ts)
+traceTree c ts = foldr join "" $ map (traceBranch c) ts
   where join = (\a b -> a ++ if b == "" then b else " " ++ b)
 
 genTrace :: [Trace] -> String
 genTrace ts = "Trace of expectance:\n" ++ traceTree 0 ts
 
 parse :: String -> Either String Tree
-parse file = case tree file of
-  Left a -> Left $ "Parse fault!\n" ++ case a of
+parse s = case tree s of
+  Left a -> Left $ "Parse error!\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
 
+check :: Tree -> Either String Tree
+check t = case checkTree t of
+  Left  a -> Left $ "Syntax error!\n" ++ (join a)
+  Right a -> Right a
+ where
+  join = foldr (\(SyntaxError a) b -> a ++ if b == "" then b else "\n" ++ b) ""
+
+-- TODO: Find higher-order infix
+f <~ e = case e of
+  Left  e -> Left e
+  Right e -> f e
+
 compile :: String -> IO ()
 compile path = do
   file <- try $ readFile path
   case file of
     Left  exception -> print (exception :: IOError)
-    Right file      -> case parse file of
+    Right file      -> case check <~ parse file of
       Left err -> do
         hPutStrLn stderr err
         exitWith (ExitFailure 1)
diff --git a/src/Fun/Grammar.hs b/src/Fun/Grammar.hs
index 7f6625d..422a211 100644
--- a/src/Fun/Grammar.hs
+++ b/src/Fun/Grammar.hs
@@ -119,6 +119,7 @@ functionPatternElement :: Parser FunctionPatternElement
 functionPatternElement =
   (functionParameter >>> FunctionPatternParameter)
     <|> (literal '_' >>> const FunctionPatternWildcard)
+    <|> (literal '_' <+-> literal '*' >>> const FunctionPatternSuperWildcard)
     <|> (number >>> FunctionPatternNumber)
     <|> (string >>> FunctionPatternString)
     <?> "function pattern element"
diff --git a/src/Fun/Syntax.hs b/src/Fun/Syntax.hs
index ab17215..133b7dc 100644
--- a/src/Fun/Syntax.hs
+++ b/src/Fun/Syntax.hs
@@ -5,16 +5,26 @@ import           Fun.Tree
 
 data SyntaxError = SyntaxError String
 
-syntaxBlock :: Block -> Either [SyntaxError] Block
-syntaxBlock (FunctionBlock decl defns) = Right $ FunctionBlock decl defns
-
 mergeSyntax :: [Either [SyntaxError] a] -> ([a] -> b) -> Either [SyntaxError] b
-mergeSyntax d c = case any isLeft d of
-  True  -> Left $ concat $ lefts d
-  False -> Right $ c $ rights d
+mergeSyntax d c | any isLeft d = Left $ concat $ lefts d
+                | otherwise    = Right $ c $ rights d
+
+checkFunctionArity :: Block -> Either [SyntaxError] Block
+checkFunctionArity (FunctionBlock decl defns) =
+  let declArity   = length $ dTypes decl
+      defnArities = map (length . pElements . dPattern) defns
+      defnFirst   = head defnArities -- can't fail because of parser
+      equality    = all (== defnFirst) defnArities
+      smaller     = defnFirst < declArity
+  in  if equality && smaller
+        then Right $ FunctionBlock decl defns
+        else Left $ [SyntaxError $ "invalid arity in function " ++ (dName decl)]
+
+checkBlock :: Block -> Either [SyntaxError] Block
+checkBlock b@(FunctionBlock _ _) = checkFunctionArity b
 
-syntaxProgram :: Program -> Either [SyntaxError] Program
-syntaxProgram (Program blocks) = mergeSyntax (map syntaxBlock blocks) Program
+checkProgram :: Program -> Either [SyntaxError] Program
+checkProgram (Program blocks) = mergeSyntax (map checkBlock blocks) Program
 
-syntaxTree :: Tree -> Either [SyntaxError] Tree
-syntaxTree (Tree programs) = mergeSyntax (map syntaxProgram programs) Tree
+checkTree :: Tree -> Either [SyntaxError] Tree
+checkTree (Tree programs) = mergeSyntax (map checkProgram programs) Tree
diff --git a/src/Fun/Tree.hs b/src/Fun/Tree.hs
index 63ca0b5..7b21b17 100644
--- a/src/Fun/Tree.hs
+++ b/src/Fun/Tree.hs
@@ -2,37 +2,53 @@ module Fun.Tree where
 
 import           Fun.Typer
 
+data Visibility = PublicVisibility | PrivateVisibility
+  deriving Show
+data FunctionFlag = FunctionInline | FunctionDeprecated | FunctionUnknown
+  deriving Show
+instance Read FunctionFlag where
+  readsPrec _ "inline"     = [(FunctionInline, "")]
+  readsPrec _ "deprecated" = [(FunctionDeprecated, "")]
+  readsPrec _ _            = [(FunctionUnknown, "")]
+
 data Tree = Tree [Program]
   deriving Show
 
 data Program = Program [Block]
   deriving Show
 
-data Block = FunctionBlock FunctionDeclaration [FunctionDefinition] -- | DataBlock .. TODO
+data Block = FunctionBlock
+  { bDecl  :: FunctionDeclaration
+  , bDefns :: [FunctionDefinition]
+  } -- | DataBlock .. TODO
   deriving Show
 
-data Visibility = PublicVisibility | PrivateVisibility
+data FunctionDeclaration = FunctionDeclaration
+  { dName       :: String
+  , dVisibility :: Visibility
+  , dTypes      :: [Type]
+  , dFlags      :: [FunctionFlag]
+  }
   deriving Show
 
-data FunctionDeclaration = FunctionDeclaration String
-                                               Visibility
-                                               [Type]
-                                               [FunctionFlag]
+data FunctionDefinition = FunctionDefinition
+  { dPattern :: FunctionPattern
+  , dBody    :: FunctionBody
+  }
   deriving Show
-data FunctionFlag = FunctionInline | FunctionDeprecated | FunctionUnknown
-  deriving Show
-instance Read FunctionFlag where
-  readsPrec _ "inline"     = [(FunctionInline, "")]
-  readsPrec _ "deprecated" = [(FunctionDeprecated, "")]
-  readsPrec _ _            = [(FunctionUnknown, "")]
 
-data FunctionDefinition = FunctionDefinition FunctionPattern FunctionBody
-  deriving Show
-data FunctionPattern = FunctionPattern [FunctionPatternElement]
+data FunctionPattern = FunctionPattern
+  { pElements :: [FunctionPatternElement]
+  }
   deriving Show
-data FunctionPatternElement = FunctionPatternParameter String | FunctionPatternString String | FunctionPatternNumber Integer | FunctionPatternWildcard
+
+data FunctionPatternElement = FunctionPatternParameter String | FunctionPatternString String | FunctionPatternNumber Integer | FunctionPatternWildcard | FunctionPatternSuperWildcard
   deriving Show
-data FunctionBody = FunctionBody [FunctionBodyElement]
+
+data FunctionBody = FunctionBody
+  { bElements :: [FunctionBodyElement]
+  }
   deriving Show
+
 data FunctionBodyElement = Statement String | FunctionBodyIdentifier String | FunctionBodyParameter String | FunctionBodyString String | FunctionBodyNumber Integer
   deriving Show