summaryrefslogtreecommitdiff
path: root/lib/Language/Elna/NameAnalysis.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Language/Elna/NameAnalysis.hs')
-rw-r--r--lib/Language/Elna/NameAnalysis.hs156
1 files changed, 75 insertions, 81 deletions
diff --git a/lib/Language/Elna/NameAnalysis.hs b/lib/Language/Elna/NameAnalysis.hs
index 78b3ce4..0ef702d 100644
--- a/lib/Language/Elna/NameAnalysis.hs
+++ b/lib/Language/Elna/NameAnalysis.hs
@@ -1,39 +1,23 @@
module Language.Elna.NameAnalysis
( nameAnalysis
- -- , Error(..)
+ , Error(..)
) where
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Vector as Vector
+import qualified Language.Elna.SymbolTable as SymbolTable
import qualified Language.Elna.AST as AST
import Language.Elna.SymbolTable
( SymbolTable
- , empty
- --, Info(..)
- -- , ParameterInfo(..)
+ , Info(..)
+ , ParameterInfo(..)
)
-
-nameAnalysis :: AST.Program -> SymbolTable -- Either Error SymbolTable
-nameAnalysis = const empty {- runExcept
- . flip runReaderT builtInSymbolTable
- . runNameAnalysis
- . program -}
-{-
import Control.Monad.Trans.Except (Except, runExcept, throwE)
-import Control.Monad.Trans.Reader
- ( ReaderT(..)
- , ask
- , asks
- , runReaderT
- , withReaderT
- )
import Data.Functor ((<&>))
import Language.Elna.Location (Identifier(..))
-import qualified Language.Elna.SymbolTable as SymbolTable
import Language.Elna.Types (Type(..))
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad (foldM, unless)
-import qualified Data.List.NonEmpty as NonEmpty
import Data.Foldable (traverse_)
-import qualified Data.Vector as Vector
+import Control.Monad (foldM)
data Error
= UndefinedTypeError Identifier
@@ -44,7 +28,7 @@ data Error
deriving (Eq, Show)
newtype NameAnalysis a = NameAnalysis
- { runNameAnalysis :: ReaderT SymbolTable (Except Error) a
+ { runNameAnalysis :: Except Error a
}
instance Functor NameAnalysis
@@ -60,30 +44,77 @@ instance Monad NameAnalysis
where
(NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
-program :: AST.Program -> NameAnalysis SymbolTable
-program (AST.Program declarations)
- = NameAnalysis ask
- >>= flip (foldM declaration) declarations
-
+nameAnalysis :: AST.Program -> Either Error SymbolTable
+nameAnalysis = runExcept
+ . runNameAnalysis
+ . program SymbolTable.builtInSymbolTable
+
+program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable
+program symbolTable (AST.Program declarations) = do
+ globalTable <- foldM procedureDeclaration symbolTable declarations
+ foldM declaration globalTable declarations
+
+procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
+procedureDeclaration globalTable (AST.ProcedureDeclaration identifier parameters _ _) = do
+ parametersInfo <- mapM (parameter globalTable) parameters
+ let procedureInfo = ProcedureInfo SymbolTable.empty
+ $ Vector.fromList parametersInfo
+ maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure
+ $ SymbolTable.enter identifier procedureInfo globalTable
+
declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
-declaration globalTable (AST.TypeDefinition identifier typeExpression)
- = withSymbolTable globalTable (dataType typeExpression)
- >>= flip (enter identifier) globalTable . TypeInfo
-declaration globalTable (AST.ProcedureDefinition identifier parameters variables body) = do
- parametersInfo <- mapM parameter parameters
- variableInfo <- mapM variableDeclaration variables
- newTable <- either (identifierAlreadyDefinedError . NonEmpty.head) pure
- $ SymbolTable.fromList
- $ fmap parameterToVariableInfo parametersInfo
- <> variableInfo
- traverse_ (statement globalTable) body
- let procedureInfo = ProcedureInfo newTable
- $ Vector.fromList parametersInfo
- enter identifier procedureInfo globalTable
+declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do
+ variableInfo <- mapM (variableDeclaration globalTable) variables
+ parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters
+ procedureTable <- fmap (SymbolTable.scope globalTable)
+ $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure
+ $ SymbolTable.fromList
+ $ parameterInfo <> variableInfo
+ traverse_ (statement procedureTable) body
+ pure $ SymbolTable.update (updater procedureTable) identifier globalTable
+ where
+ updater procedureTable (ProcedureInfo _ parameters') = Just
+ $ ProcedureInfo procedureTable parameters'
+ updater _ _ = Nothing
+
+parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info)
+parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter')
+ = (identifier,) . VariableInfo isReferenceParameter'
+ <$> dataType symbolTable typeExpression
+
+variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
+variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression)
+ = (identifier,) . VariableInfo False
+ <$> dataType globalTable typeExpression
+
+parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo
+parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do
+ parameterType <- dataType environmentSymbolTable typeExpression
+ case parameterType of
+ ArrayType _ _
+ | not isReferenceParameter' -> NameAnalysis
+ $ throwE $ UnexpectedArrayByValue identifier
+ _ ->
+ let parameterInfo = ParameterInfo
+ { name = identifier
+ , type' = parameterType
+ , isReferenceParameter = isReferenceParameter'
+ }
+ in pure parameterInfo
+
+dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type
+dataType environmentSymbolTable (AST.NamedType baseType) = do
+ case SymbolTable.lookup baseType environmentSymbolTable of
+ Just baseInfo
+ | TypeInfo baseType' <- baseInfo -> pure baseType'
+ | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
+ _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
+dataType environmentSymbolTable (AST.ArrayType arraySize baseType) =
+ dataType environmentSymbolTable baseType <&> ArrayType arraySize
statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
statement _ AST.EmptyStatement = pure ()
-statement globalTable (AST.AssignmentStatement lvalue rvalue)
+{- statement globalTable (AST.AssignmentStatement lvalue rvalue)
= variableAccess globalTable lvalue
>> expression globalTable rvalue
statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
@@ -170,41 +201,4 @@ variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info
variableDeclaration (AST.VariableDeclaration identifier typeExpression)
= (identifier,) . VariableInfo False
<$> dataType typeExpression
-
-parameter :: AST.Parameter -> NameAnalysis ParameterInfo
-parameter (AST.Parameter identifier typeExpression isReferenceParameter') = do
- parameterType <- dataType typeExpression
- case parameterType of
- ArrayType _ _
- | not isReferenceParameter' -> NameAnalysis
- $ lift $ throwE $ UnexpectedArrayByValue identifier
- _ ->
- let parameterInfo = ParameterInfo
- { name = identifier
- , type' = parameterType
- , isReferenceParameter = isReferenceParameter'
- }
- in pure parameterInfo
-
-parameterToVariableInfo :: ParameterInfo -> (Identifier, Info)
-parameterToVariableInfo ParameterInfo{..} =
- ( name
- , VariableInfo isReferenceParameter type'
- )
-
-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 ask
- case SymbolTable.lookup baseType environmentSymbolTable of
- Just baseInfo
- | TypeInfo baseType' <- baseInfo -> pure baseType'
- | otherwise -> NameAnalysis $ lift $ throwE $ UnexpectedTypeInfoError baseInfo
- _ -> NameAnalysis $ lift $ throwE $ UndefinedTypeError baseType
-dataType (AST.ArrayType arraySize baseType) =
- dataType baseType <&> ArrayType arraySize
-}
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 21:45:33 +0000