Collect types into the global symbol table

TODO

@@ -4,6 +4,6 @@
   Give errors if:
   - The type is already defined.
   - Base type is not defined.
-  - Circular type reference.
+  - Replace equivalent type with its base type.
 
 - Check definitions inside procedures.

elna.cabal

@@ -35,6 +35,7 @@ library elna-internal
         Language.Elna.SymbolTable
         Language.Elna.Types
     build-depends:
+        exceptions ^>= 0.10,
         hashable ^>= 1.4.3,
         parser-combinators ^>= 1.3,
         transformers ^>= 0.6.1,
@@ -54,6 +55,7 @@ test-suite elna-test
     type: exitcode-stdio-1.0
     main-is: Spec.hs
     other-modules:
+        Language.Elna.NameAnalysisSpec
         Language.Elna.ParserSpec
     hs-source-dirs:
         tests

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.Except (Except, runExcept, throwE)
-import Control.Monad.Trans.Reader (Reader, ask, runReader)
+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
+nameAnalysis = runExcept
-    . runExceptT
+    . flip runReaderT symbolTable
     . runNameAnalysis
     . program
 
 program :: AST.Program -> NameAnalysis SymbolTable
-program (AST.Program declarations) = do
+program (AST.Program declarations)
-    globalDeclarations <- traverse declaration declarations
+    = NameAnalysis ask
-    NameAnalysis $ lift ask
+    >>= flip (foldM declaration) declarations
 
-declaration :: AST.Declaration -> NameAnalysis (Identifier, Info)
+declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
-declaration (AST.TypeDefinition identifier typeExpression) =
+declaration globalTable (AST.TypeDefinition identifier typeExpression)
-    (identifier,) . TypeInfo <$> dataType typeExpression
+    = flip (SymbolTable.enter identifier) globalTable . TypeInfo
-declaration (AST.ProcedureDefinition identifier _parameters _variables _body) = do
+    <$> withSymbolTable globalTable (dataType typeExpression)
-    environmentSymbolTable <- NameAnalysis $ lift ask
+
-    pure (identifier, ProcedureInfo environmentSymbolTable mempty)
+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
+            | otherwise -> NameAnalysis $ lift $ throwE $ UnexpectedTypeInfoError baseInfo
-        _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
+        _ -> 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

tests/Language/Elna/NameAnalysisSpec.hs

@@ -0,0 +1,45 @@
+module Language.Elna.NameAnalysisSpec
+    ( spec
+    ) where
+
+import Data.Text (Text)
+import Text.Megaparsec (runParser)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy, pendingWith)
+import Language.Elna.NameAnalysis (Error(..), nameAnalysis)
+import Language.Elna.SymbolTable (Info(..), SymbolTable)
+import qualified Language.Elna.SymbolTable as SymbolTable
+import qualified Language.Elna.Parser as AST
+import Language.Elna.Types (intType)
+import Control.Exception (throwIO)
+
+nameAnalysisOnText :: Text -> IO (Either Error SymbolTable)
+nameAnalysisOnText sourceText = nameAnalysis
+    <$> either throwIO pure (runParser AST.programP "" sourceText)
+
+spec :: Spec
+spec = describe "nameAnalysis" $ do
+    it "adds type to the symbol table" $ do
+        let given = "type A = int"
+            expected = Right $ Just $ TypeInfo intType
+        actual <- nameAnalysisOnText given
+
+        actual `shouldSatisfy` (expected ==) . fmap (SymbolTable.lookup "A")
+
+    it "errors when the aliased type is not defined" $ do
+        let given = "type A = B"
+            expected = Left $ UndefinedTypeError "B"
+        actual <- nameAnalysisOnText given
+
+        actual `shouldBe` expected
+
+    it "errors if the aliased identifier is not a type" $ do
+        let given = "proc main() {} type A = main"
+            expected = Left
+                $ UnexpectedTypeInfoError
+                $ ProcedureInfo mempty mempty
+        actual <- nameAnalysisOnText given
+
+        actual `shouldBe` expected
+
+    it "replaces the alias with an equivalent base type" $
+        pendingWith "Not implemented"