Collect types into the global symbol table

lib/Language/Elna/NameAnalysis.hs

@@ -3,8 +3,8 @@ module Language.Elna.NameAnalysis
     , nameAnalysis
     ) where
 
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
-import Control.Monad.Trans.Reader (Reader, ask, runReader)
+import Control.Monad.Trans.Except (Except, runExcept, throwE)
+import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT, withReaderT)
 import Data.Functor ((<&>))
 import qualified Language.Elna.AST as AST
 import Language.Elna.Location (Identifier(..))
@@ -12,6 +12,7 @@ import Language.Elna.SymbolTable (Info(..), SymbolTable, symbolTable)
 import qualified Language.Elna.SymbolTable as SymbolTable
 import Language.Elna.Types (Type(..))
 import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad (foldM)
 
 data Error
     = UndefinedTypeError Identifier
@@ -19,7 +20,7 @@ data Error
     deriving (Eq, Show)
 
 newtype NameAnalysis a = NameAnalysis
-    { runNameAnalysis :: ExceptT Error (Reader SymbolTable) a
+    { runNameAnalysis :: ReaderT SymbolTable (Except Error) a
     }
 
 instance Functor NameAnalysis
@@ -36,30 +37,37 @@ instance Monad NameAnalysis
     (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
 
 nameAnalysis :: AST.Program -> Either Error SymbolTable
-nameAnalysis = flip runReader symbolTable
-    . runExceptT
+nameAnalysis = runExcept
+    . flip runReaderT symbolTable
     . runNameAnalysis
     . program
 
 program :: AST.Program -> NameAnalysis SymbolTable
-program (AST.Program declarations) = do
-    globalDeclarations <- traverse declaration declarations
-    NameAnalysis $ lift ask
+program (AST.Program declarations)
+    = NameAnalysis ask
+    >>= flip (foldM declaration) declarations
 
-declaration :: AST.Declaration -> NameAnalysis (Identifier, Info)
-declaration (AST.TypeDefinition identifier typeExpression) =
-    (identifier,) . TypeInfo <$> dataType typeExpression
-declaration (AST.ProcedureDefinition identifier _parameters _variables _body) = do
-    environmentSymbolTable <- NameAnalysis $ lift ask
-    pure (identifier, ProcedureInfo environmentSymbolTable mempty)
+declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
+declaration globalTable (AST.TypeDefinition identifier typeExpression)
+    = flip (SymbolTable.enter identifier) globalTable . TypeInfo
+    <$> withSymbolTable globalTable (dataType typeExpression)
+
+declaration globalTable (AST.ProcedureDefinition identifier _parameters _variables _body) =
+    let localTable = SymbolTable.empty
+     in pure $ SymbolTable.enter identifier (ProcedureInfo localTable mempty) globalTable
+
+withSymbolTable :: forall a. SymbolTable -> NameAnalysis a -> NameAnalysis a
+withSymbolTable symbolTable' = NameAnalysis
+    . withReaderT (const symbolTable')
+    . runNameAnalysis
 
 dataType :: AST.TypeExpression -> NameAnalysis Type
 dataType (AST.NamedType baseType) = do
-    environmentSymbolTable <- NameAnalysis $ lift ask
+    environmentSymbolTable <- NameAnalysis ask
     case SymbolTable.lookup baseType environmentSymbolTable of
         Just baseInfo
             | TypeInfo baseType' <- baseInfo -> pure baseType'
-            | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
-        _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
+            | otherwise -> NameAnalysis $ lift $ throwE $ UnexpectedTypeInfoError baseInfo
+        _ -> NameAnalysis $ lift $ throwE $ UndefinedTypeError baseType
 dataType (AST.ArrayType arraySize baseType) =
     dataType baseType <&> ArrayType arraySize

lib/Language/Elna/SymbolTable.hs

@@ -2,6 +2,7 @@ module Language.Elna.SymbolTable
     ( Info(..)
     , ParameterInfo(..)
     , SymbolTable
+    , empty
     , enter
     , lookup
     , symbolTable
@@ -31,6 +32,9 @@ symbolTable = SymbolTable $ HashMap.fromList
     , ("int", TypeInfo intType)
     ]
 
+empty :: SymbolTable
+empty = SymbolTable HashMap.empty
+
 enter :: Identifier -> Info -> SymbolTable -> SymbolTable
 enter identifier info (SymbolTable table) = SymbolTable
     $ HashMap.insert identifier info table