struct variable type checking, refactoring to avoid circular dependencies

src/Ubc/Parse/Data/Struct.hs

@@ -0,0 +1,14 @@
+module Ubc.Parse.Data.Struct
+( Struct(..)
+)
+where
+
+import Data.Map (Map)
+
+import Ubc.Parse.VariableType (VariableType)
+
+data Struct = Struct 
+        { name :: String
+        , memberVariables :: Map String VariableType
+        }
+        deriving (Show)

src/Ubc/Parse/File.hs

@@ -0,0 +1,5 @@
+module Ubc.Parse.File
+(
+)
+where
+

src/Ubc/Parse/Language.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module Ubc.Parse.Language
+( languageDef
+, typeName
+, Ubc.Parse.Language.identifier         
+, Ubc.Parse.Language.reserved           
+, Ubc.Parse.Language.operator           
+, Ubc.Parse.Language.reservedOperator   
+, Ubc.Parse.Language.characterLiteral   
+, Ubc.Parse.Language.stringLiteral      
+, Ubc.Parse.Language.natural            
+, Ubc.Parse.Language.integer            
+, Ubc.Parse.Language.float              
+, Ubc.Parse.Language.naturalOrFloat     
+, Ubc.Parse.Language.decimal            
+, Ubc.Parse.Language.hexadecimal        
+, Ubc.Parse.Language.octal              
+, Ubc.Parse.Language.symbol             
+, Ubc.Parse.Language.lexeme             
+, Ubc.Parse.Language.whiteSpace         
+, Ubc.Parse.Language.parens             
+, Ubc.Parse.Language.braces             
+, Ubc.Parse.Language.angles             
+, Ubc.Parse.Language.brackets           
+, Ubc.Parse.Language.semicolon          
+, Ubc.Parse.Language.comma              
+, Ubc.Parse.Language.colon              
+, Ubc.Parse.Language.dot                
+, Ubc.Parse.Language.semicolonSeparated 
+, Ubc.Parse.Language.semicolonSeparated1
+, Ubc.Parse.Language.commaSeparated     
+, Ubc.Parse.Language.commaSeparated1    
+)
+where
+
+import Data.Functor ( ($>) )
+import Text.Parsec
+    ( alphaNum, char, letter, oneOf, choice, (<|>), ParsecT )
+import Text.Parsec.Token
+    ( makeTokenParser,
+      GenLanguageDef(..),
+      GenTokenParser(TokenParser, identifier, reserved, operator,
+                     reservedOp, charLiteral, stringLiteral, natural, integer, float,
+                     naturalOrFloat, decimal, hexadecimal, octal, symbol, lexeme,
+                     whiteSpace, parens, braces, angles, brackets, semi, comma, colon,
+                     dot, semiSep, semiSep1, commaSep, commaSep1) )
+
+languageDef :: Monad m => GenLanguageDef String u m
+languageDef = LanguageDef {
+          commentStart = "/*"
+        , commentEnd = "*/"
+        , commentLine = "//"
+        , nestedComments = True
+        , identStart = letter <|> char '_'
+        , identLetter = alphaNum <|> char '_'
+        , opStart = oneOf "+-*/"
+        , opLetter = oneOf "+-*/"
+        , reservedNames = [ "struct", "u32", "i32", "f32" ]
+        , reservedOpNames = [ "+", "-", "*", "/" ]
+        , caseSensitive = True
+        }
+
+tokenParser :: Monad m => GenTokenParser String u m
+tokenParser = makeTokenParser languageDef
+
+identifier              :: Monad m => ParsecT String u m String
+reserved                :: Monad m => String -> ParsecT String u m ()
+operator                :: Monad m => ParsecT String u m String
+reservedOperator        :: Monad m => String -> ParsecT String u m ()
+characterLiteral        :: Monad m => ParsecT String u m Char
+stringLiteral           :: Monad m => ParsecT String u m String
+natural                 :: Monad m => ParsecT String u m Integer
+integer                 :: Monad m => ParsecT String u m Integer
+float                   :: Monad m => ParsecT String u m Double
+naturalOrFloat          :: Monad m => ParsecT String u m (Either Integer Double)
+decimal                 :: Monad m => ParsecT String u m Integer
+hexadecimal             :: Monad m => ParsecT String u m Integer
+octal                   :: Monad m => ParsecT String u m Integer
+symbol                  :: Monad m => String -> ParsecT String u m String
+lexeme                  :: Monad m => ParsecT String u m a -> ParsecT String u m a
+whiteSpace              :: Monad m => ParsecT String u m ()
+parens                  :: Monad m => ParsecT String u m a -> ParsecT String u m a
+braces                  :: Monad m => ParsecT String u m a -> ParsecT String u m a
+angles                  :: Monad m => ParsecT String u m a -> ParsecT String u m a
+brackets                :: Monad m => ParsecT String u m a -> ParsecT String u m a
+semicolon               :: Monad m => ParsecT String u m String
+comma                   :: Monad m => ParsecT String u m String
+colon                   :: Monad m => ParsecT String u m String
+dot                     :: Monad m => ParsecT String u m String
+semicolonSeparated      :: Monad m => ParsecT String u m a -> ParsecT String u m [a]
+semicolonSeparated1     :: Monad m => ParsecT String u m a -> ParsecT String u m [a]
+commaSeparated          :: Monad m => ParsecT String u m a -> ParsecT String u m [a]
+commaSeparated1         :: Monad m => ParsecT String u m a -> ParsecT String u m [a]
+TokenParser{
+          identifier            = identifier
+        , reserved              = reserved
+        , operator              = operator
+        , reservedOp            = reservedOperator
+        , charLiteral           = characterLiteral
+        , stringLiteral         = stringLiteral
+        , natural               = natural -- decimal, hexadecimal or octal
+        , integer               = integer -- decimal, hexadecimal or octal
+        , float                 = float
+        , naturalOrFloat        = naturalOrFloat
+        , decimal               = decimal
+        , hexadecimal           = hexadecimal
+        , octal                 = octal
+        , symbol                = symbol
+        , lexeme                = lexeme
+        , whiteSpace            = whiteSpace
+        , parens                = parens
+        , braces                = braces
+        , angles                = angles
+        , brackets              = brackets
+        , semi                  = semicolon
+        , comma                 = comma
+        , colon                 = colon
+        , dot                   = dot
+        , semiSep               = semicolonSeparated
+        , semiSep1              = semicolonSeparated1
+        , commaSep              = commaSeparated
+        , commaSep1             = commaSeparated1
+        } = tokenParser
+
+typeName :: Monad m => ParsecT String u m String
+typeName = choice
+        [ Ubc.Parse.Language.reserved "i32" $> "i32"
+        , Ubc.Parse.Language.reserved "u32" $> "u32"
+        , Ubc.Parse.Language.reserved "f32" $> "f32"
+        , Ubc.Parse.Language.identifier
+        ]

src/Ubc/Parse/ParserState.hs

@@ -0,0 +1,26 @@
+module Ubc.Parse.ParserState
+( ParserState(..)
+, initialState
+, pushScope
+, popScope
+, modifyScope
+)
+where
+
+import Ubc.Parse.Scope (Scope)
+
+data ParserState = ParserState
+        { scopes :: [Scope]
+        }
+
+initialState :: ParserState
+initialState = ParserState []
+
+pushScope :: Scope -> ParserState -> ParserState
+pushScope scope oldState@ParserState{scopes = oldScopes} = oldState{scopes = scope : oldScopes}
+
+popScope :: ParserState -> (ParserState, Scope)
+popScope oldState@ParserState{scopes = (topScope:restScopes)} = (oldState{scopes = restScopes}, topScope)
+
+modifyScope :: (Scope -> Scope) -> ParserState -> ParserState
+modifyScope f oldState@ParserState{scopes = (topScope:restScopes)} = oldState{scopes = f topScope : restScopes}

src/Ubc/Parse/Scope.hs

@@ -0,0 +1,16 @@
+module Ubc.Parse.Scope
+( Scope(..)
+, expectScopeStruct
+)
+where
+
+import Ubc.Parse.Scope.FileScope (FileScope)
+import Ubc.Parse.Scope.StructScope (StructScope)
+
+data Scope = 
+          ScopeFile FileScope
+        | ScopeStruct StructScope
+
+expectScopeStruct :: Scope -> StructScope
+expectScopeStruct (ScopeStruct s) = s
+expectScopeStruct _               = error "Internal Error: Top Scope is not Scope Struct"

src/Ubc/Parse/Scope/FileScope.hs

@@ -0,0 +1,11 @@
+module Ubc.Parse.Scope.FileScope
+( FileScope(..)
+)
+where
+
+import Data.Map (Map)
+import Ubc.Parse.Data.Struct (Struct)
+
+data FileScope = FileScope
+        { structs :: Map String Struct
+        }

src/Ubc/Parse/Scope/StructScope.hs

@@ -0,0 +1,19 @@
+module Ubc.Parse.Scope.StructScope
+( StructScope(..)
+, modifyVariables
+)
+where
+
+import Data.Map (Map)
+
+import Ubc.Parse.VariableType (VariableType)
+
+data StructScope = StructScope
+        { structName :: String
+        , variables :: Map String VariableType
+        }
+
+modifyVariables :: (Map String VariableType -> Map String VariableType) -> StructScope -> StructScope
+modifyVariables f scope@StructScope{variables = oldVariables} = scope{variables = newVariables}
+        where
+                newVariables = f oldVariables

src/Ubc/Parse/Struct.hs

@@ -0,0 +1,89 @@
+module Ubc.Parse.Struct
+( Struct(..)
+, parseStruct
+)
+where
+
+import Data.Functor ( (<&>) )
+import Control.Arrow ( Arrow(second) )
+
+import Text.Parsec
+    ( char,
+      choice,
+      getState,
+      lookAhead,
+      many,
+      modifyState,
+      try,
+      unexpected,
+      ParsecT )
+
+import Ubc.Parse.ParserState (ParserState)
+import Ubc.Parse.Scope.StructScope (StructScope(..))
+import Ubc.Parse.Scope (Scope(..))
+import Ubc.Parse.Types (checkTypeValidity)
+import Ubc.Parse.Data.Struct (Struct(..))
+
+import qualified Ubc.Parse.Language as UbcLanguage
+import qualified Ubc.Parse.Scope.StructScope as StructScope
+import qualified Ubc.Parse.ParserState as ParserState
+import qualified Ubc.Parse.Scope as Scope
+import qualified Ubc.Parse.VariableType as VariableType
+
+import qualified Data.Map as Map
+
+parseStruct :: Monad m => ParsecT String ParserState m Struct
+parseStruct = do
+        _ <- UbcLanguage.reserved "struct"
+
+        structIdentifier <- UbcLanguage.identifier
+        let structScope = StructScope
+                { structName = structIdentifier 
+                , variables = Map.empty
+                }
+
+        modifyState (ParserState.pushScope . ScopeStruct $ structScope)
+
+        _ <- UbcLanguage.braces (many structMember)
+
+        structScope' <- getState <&> Scope.expectScopeStruct . snd . ParserState.popScope
+
+        return $ Struct (StructScope.structName structScope') (StructScope.variables structScope')
+
+structMember :: Monad m => ParsecT String ParserState m ()
+structMember = choice [ structVariableOrFunction ]
+
+structVariableOrFunction :: Monad m => ParsecT String ParserState m ()
+structVariableOrFunction = do
+        (typeName, identifier) <- try $ do
+                typeName <- UbcLanguage.typeName
+                objectIdentifier <- UbcLanguage.identifier
+                return (typeName, objectIdentifier)
+        choice 
+                [ lookAhead (char ';') *> parseVariable typeName identifier
+                ] -- TODO: Functions on structs
+
+parseVariable :: Monad m => String -> String -> ParsecT String ParserState m ()
+parseVariable variableType variableName = do
+        _ <- UbcLanguage.semicolon
+        -- TODO: Validate type
+
+        (_, structScope) <- getState <&> second Scope.expectScopeStruct . ParserState.popScope
+
+        -- check variable name
+        if (/= Nothing) . Map.lookup variableName . StructScope.variables $ structScope
+        then do
+                unexpected $ "variable name: \"" ++ variableName ++ "\", this name is already defined"
+        else do
+                return ()
+
+        -- check type
+        isKnownType <- checkTypeValidity variableType
+        if not isKnownType
+        then do
+                unexpected $ "variable type: \"" ++ variableType ++ "\", this type is not defined"
+        else do
+                return ()
+
+        let structScope' = StructScope.modifyVariables (Map.insert variableName (VariableType.fromString variableType)) structScope
+        modifyState (ParserState.pushScope $ ScopeStruct structScope')

src/Ubc/Parse/Types.hs

@@ -0,0 +1,20 @@
+module Ubc.Parse.Types
+( checkTypeValidity
+, getTypeNames
+)
+where
+
+import Text.Parsec
+
+import qualified Data.Set as Set
+
+import Ubc.Parse.ParserState (ParserState)
+
+checkTypeValidity :: Monad m => String -> ParsecT String ParserState m Bool
+checkTypeValidity typeName = do
+        typeNames <- getTypeNames >>= return . Set.union (Set.fromList ["i32", "u32", "f32"]) . Set.fromList
+        return $ typeName `Set.member` typeNames
+
+getTypeNames :: Monad m => ParsecT String ParserState m [String]
+getTypeNames = do
+        return []

src/Ubc/Parse/VariableType.hs

@@ -0,0 +1,14 @@
+module Ubc.Parse.VariableType
+(VariableType(..)
+, fromString
+)
+where
+
+data VariableType = BuiltInI32 | BuiltInU32 | BuiltInF32 | UserStruct String
+        deriving (Show, Eq)
+
+fromString :: String -> VariableType
+fromString "i32" = BuiltInI32
+fromString "u32" = BuiltInU32
+fromString "f32" = BuiltInF32
+fromString s     = UserStruct s