Collect types into the global symbol table

1 files changed, 25 insertions, 17 deletions

diff --git a/lib/Language/Elna/NameAnalysis.hs b/lib/Language/Elna/NameAnalysis.hs
index abbfb93..49b7915 100644
--- a/lib/Language/Elna/NameAnalysis.hs
+++ b/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