diff --git a/TODO b/TODO index 69b9730..ff1687a 100644 --- a/TODO +++ b/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. diff --git a/elna.cabal b/elna.cabal index 3c6803d..da5e162 100644 --- a/elna.cabal +++ b/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 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 diff --git a/lib/Language/Elna/SymbolTable.hs b/lib/Language/Elna/SymbolTable.hs index ba2e41f..f1c6534 100644 --- a/lib/Language/Elna/SymbolTable.hs +++ b/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 diff --git a/tests/Language/Elna/NameAnalysisSpec.hs b/tests/Language/Elna/NameAnalysisSpec.hs new file mode 100644 index 0000000..c94e6c7 --- /dev/null +++ b/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"