From 031ec4052653e1a0256e816bc50239e4f20c42aa Mon Sep 17 00:00:00 2001
From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Thu, 13 Sep 2012 19:23:24 +0100
Subject: [PATCH] Work on validating input.

---
 src/ParsedOFL.hs | 46 +++++++++++++++++++++++++++++++++++++++++-----
 src/Parsing.hs   |  2 +-
 2 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/src/ParsedOFL.hs b/src/ParsedOFL.hs
index 745a85d..aea3dff 100644
--- a/src/ParsedOFL.hs
+++ b/src/ParsedOFL.hs
@@ -3,7 +3,7 @@ import Data.Map as Map
 
 -- The top-level types
 data BaseType = Real | Function | Integer deriving Show
-data IndexType = FunctionIndex | SpinIndex | SpatialIndex deriving Show
+data IndexType = FunctionIndex | SpinIndex | SpatialIndex deriving (Show, Eq)
 
 -- Expressions
 data Expression = IndexedIdentifier String [String] |
@@ -21,7 +21,8 @@ data Expression = IndexedIdentifier String [String] |
                   Component Expression String |
                   Derivative Expression String deriving Show
 
-data Assignment = Assign String [String] Expression deriving Show
+data Assignment = Assign Expression Expression deriving Show
+data ValidationResult = Valid | Invalid String
 
 -- The symbol table
 data SymbolType = ValueTag BaseType [IndexType] | IndexTag IndexType deriving Show
@@ -40,12 +41,47 @@ addIndexDeclaration :: OFL -> String -> IndexType -> OFL
 addIndexDeclaration ofl name indexType = ofl { symbols = symbols' }
   where symbols' = insertWithKey errorOnDuplicate name (IndexTag indexType) (symbols ofl)
 
-addAssignment :: OFL -> Expression -> Expression  -> OFL
-addAssignment ofl (IndexedIdentifier name indices) rhs = ofl { assignments = (Assign name indices rhs):(assignments ofl) } 
-addAssignment _ _ _ = error "left-hand side of assignment does not appear to be an lvalue."
+addAssignment :: OFL -> Expression -> Expression -> OFL
+addAssignment ofl lhs rhs = let assignment = (Assign lhs rhs) in
+  case (validateAssignment ofl assignment) of
+    Valid -> ofl { assignments = (Assign lhs rhs):(assignments ofl) } 
+    Invalid reason -> error reason
 
 errorOnDuplicate :: Show k => k -> a -> a -> a
 errorOnDuplicate key _ _ = error $ "Attempted redefinition of symbol " ++ show key
 
+getIndices :: OFL -> String -> Maybe [IndexType]
+getIndices ofl name = 
+ case Map.lookup name (symbols ofl) of
+ Nothing -> Nothing
+ Just (IndexTag _) -> Nothing
+ Just (ValueTag _ indices) -> Just indices
+
+getIndexType :: OFL -> String -> Maybe IndexType
+getIndexType ofl name = case Map.lookup name (symbols ofl) of
+ Nothing -> Nothing
+ Just (IndexTag indexType) -> Just indexType
+ Just (ValueTag _ _) -> Nothing
+
 emptyOFL :: OFL
 emptyOFL = OFL { assignments = [], symbols = Map.empty }
+
+validateAssignment :: OFL -> Assignment -> ValidationResult
+validateAssignment ofl (Assign lhs rhs) = case (validateExpression ofl lhs) of
+ Invalid reason -> Invalid $ "Invalid LHS of assignment" ++ reason
+ Valid -> case (validateExpression ofl rhs) of
+   Valid -> Valid
+   Invalid reason -> Invalid $ "Invalid RHS of assignment: " ++ reason
+
+validateExpression :: OFL -> Expression -> ValidationResult
+validateExpression ofl (IndexedIdentifier name indices) = 
+  case getIndices ofl name of
+   Nothing -> Invalid $ "Cannot find declaration for value " ++ show name
+   Just indexTypes -> let lengthMatch = (length indices) == (length indexTypes) in
+     case lengthMatch of 
+      False -> Invalid $ "Value " ++ show name ++ " used with wrong number of indices."
+      True -> let typeMatch = (Prelude.map (getIndexType ofl) indices) == (Prelude.map Just indexTypes) in
+        case typeMatch of
+          True -> Valid
+          False -> Invalid $ "Value " ++ show name ++ "indexed with invalid indices." 
+validateExpression ofl e = Invalid $ "Don't know how to validate " ++ show e
diff --git a/src/Parsing.hs b/src/Parsing.hs
index 87eacaa..ecafd98 100644
--- a/src/Parsing.hs
+++ b/src/Parsing.hs
@@ -97,7 +97,7 @@ parseIdentifierAccess = do { identifier <- parseIdentifier;
                              return $ IndexedIdentifier identifier indices
                            } <?> "indexed identifier"
 
-parseTarget = oflSymbol "target" >> oflIdentifier
+parseTarget = oflReserved "target" >> oflIdentifier
 
 parseOFL :: Parsec String OFL OFL
 parseOFL = do { oflWhiteSpace; 
-- 
2.47.3