Negate integral expressions
This commit is contained in:
169
lib/Language/Elna/Frontend/AST.hs
Normal file
169
lib/Language/Elna/Frontend/AST.hs
Normal file
@ -0,0 +1,169 @@
|
||||
module Language.Elna.Frontend.AST
|
||||
( Declaration(..)
|
||||
, Identifier(..)
|
||||
, Parameter(..)
|
||||
, Program(..)
|
||||
, Statement(..)
|
||||
, TypeExpression(..)
|
||||
, VariableDeclaration(..)
|
||||
{-, VariableAccess(..)
|
||||
, Condition(..)-}
|
||||
, Expression(..)
|
||||
, Literal(..)
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.List (intercalate)
|
||||
import Data.Word ({-Word16, -}Word32)
|
||||
import Language.Elna.Location (Identifier(..), showArrayType)
|
||||
|
||||
newtype Program = Program [Declaration]
|
||||
deriving Eq
|
||||
|
||||
instance Show Program
|
||||
where
|
||||
show (Program declarations) = unlines (show <$> declarations)
|
||||
|
||||
data Declaration
|
||||
= ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement]
|
||||
-- | TypeDefinition Identifier TypeExpression
|
||||
deriving Eq
|
||||
|
||||
instance Show Declaration
|
||||
where
|
||||
{- show (TypeDefinition identifier typeExpression) =
|
||||
concat ["type ", show identifier, " = ", show typeExpression, ";"] -}
|
||||
show (ProcedureDeclaration procedureName parameters variables body)
|
||||
= "proc " <> show procedureName <> showParameters parameters <> " {\n"
|
||||
<> unlines ((" " <>) . show <$> variables)
|
||||
<> unlines ((" " <>) . show <$> body)
|
||||
<> "}"
|
||||
|
||||
data Parameter = Parameter Identifier TypeExpression Bool
|
||||
deriving Eq
|
||||
|
||||
instance Show Parameter
|
||||
where
|
||||
show (Parameter identifier typeName ref) = concat
|
||||
[ if ref then "ref " else ""
|
||||
, show identifier, ": ", show typeName
|
||||
]
|
||||
|
||||
showParameters :: [Parameter] -> String
|
||||
showParameters parameters =
|
||||
"(" <> intercalate ", " (show <$> parameters) <> ")"
|
||||
|
||||
data TypeExpression
|
||||
= NamedType Identifier
|
||||
| ArrayType Word32 TypeExpression
|
||||
deriving Eq
|
||||
|
||||
instance Show TypeExpression
|
||||
where
|
||||
show (NamedType typeName) = show typeName
|
||||
show (ArrayType elementCount typeName) = showArrayType elementCount typeName
|
||||
|
||||
data Statement
|
||||
= EmptyStatement
|
||||
{-| AssignmentStatement VariableAccess Expression
|
||||
| IfStatement Condition Statement (Maybe Statement)
|
||||
| WhileStatement Condition Statement
|
||||
| CompoundStatement [Statement]-}
|
||||
| CallStatement Identifier [Expression]
|
||||
deriving Eq
|
||||
|
||||
instance Show Statement
|
||||
where
|
||||
show EmptyStatement = ";"
|
||||
{-show (AssignmentStatement lhs rhs) =
|
||||
concat [show lhs, " := ", show rhs, ";"]
|
||||
show (IfStatement condition if' else') = concat
|
||||
[ "if (", show condition, ") "
|
||||
, show if'
|
||||
, maybe "" ((<> " else ") . show) else'
|
||||
]
|
||||
show (WhileStatement expression statement) =
|
||||
concat ["while (", show expression, ") ", show statement, ";"]
|
||||
show (CompoundStatement statements) =
|
||||
concat ["{\n", unlines (show <$> statements), " }"]-}
|
||||
show (CallStatement name parameters) = show name <> "("
|
||||
<> intercalate ", " (show <$> parameters) <> ")"
|
||||
|
||||
data VariableDeclaration =
|
||||
VariableDeclaration Identifier TypeExpression
|
||||
deriving Eq
|
||||
|
||||
newtype Literal
|
||||
= IntegerLiteral Int32
|
||||
{- | HexadecimalLiteral Int32
|
||||
| CharacterLiteral Word16
|
||||
| BooleanLiteral Bool -}
|
||||
deriving Eq
|
||||
|
||||
instance Show Literal
|
||||
where
|
||||
show (IntegerLiteral integer) = show integer
|
||||
{- show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
|
||||
show (CharacterLiteral character) =
|
||||
'\'' : chr (fromEnum character) : ['\'']
|
||||
show (BooleanLiteral boolean)
|
||||
| boolean = "true"
|
||||
| otherwise = "false" -}
|
||||
|
||||
instance Show VariableDeclaration
|
||||
where
|
||||
show (VariableDeclaration identifier typeExpression) =
|
||||
concat ["var ", show identifier, ": " <> show typeExpression, ";"]
|
||||
|
||||
data Expression
|
||||
= LiteralExpression Literal
|
||||
| SumExpression Expression Expression
|
||||
| SubtractionExpression Expression Expression
|
||||
| NegationExpression Expression
|
||||
{- | VariableExpression VariableAccess
|
||||
| ProductExpression Expression Expression
|
||||
| DivisionExpression Expression Expression -}
|
||||
deriving Eq
|
||||
|
||||
instance Show Expression
|
||||
where
|
||||
show (LiteralExpression literal) = show literal
|
||||
show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs]
|
||||
show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs]
|
||||
show (NegationExpression negation) = '-' : show negation
|
||||
{- show (VariableExpression variable) = show variable
|
||||
show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
|
||||
show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs] -}
|
||||
{-
|
||||
import Data.Char (chr)
|
||||
import Numeric (showHex)
|
||||
|
||||
data VariableAccess
|
||||
= VariableAccess Identifier
|
||||
| ArrayAccess VariableAccess Expression
|
||||
deriving Eq
|
||||
|
||||
instance Show VariableAccess
|
||||
where
|
||||
show (VariableAccess variableName) = show variableName
|
||||
show (ArrayAccess arrayAccess elementIndex) =
|
||||
concat [show arrayAccess, "[", show elementIndex, "]"]
|
||||
|
||||
data Condition
|
||||
= EqualCondition Expression Expression
|
||||
| NonEqualCondition Expression Expression
|
||||
| LessCondition Expression Expression
|
||||
| GreaterCondition Expression Expression
|
||||
| LessOrEqualCondition Expression Expression
|
||||
| GreaterOrEqualCondition Expression Expression
|
||||
deriving Eq
|
||||
|
||||
instance Show Condition
|
||||
where
|
||||
show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs]
|
||||
show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs]
|
||||
show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs]
|
||||
show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs]
|
||||
show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs]
|
||||
show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs]
|
||||
-}
|
||||
216
lib/Language/Elna/Frontend/NameAnalysis.hs
Normal file
216
lib/Language/Elna/Frontend/NameAnalysis.hs
Normal file
@ -0,0 +1,216 @@
|
||||
module Language.Elna.Frontend.NameAnalysis
|
||||
( nameAnalysis
|
||||
, Error(..)
|
||||
) where
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Language.Elna.Frontend.AST as AST
|
||||
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
|
||||
import Language.Elna.Frontend.SymbolTable
|
||||
( SymbolTable
|
||||
, Info(..)
|
||||
, ParameterInfo(..)
|
||||
)
|
||||
import Control.Monad.Trans.Except (Except, runExcept, throwE)
|
||||
import Data.Functor ((<&>))
|
||||
import Language.Elna.Location (Identifier(..))
|
||||
import Language.Elna.Frontend.Types (Type(..))
|
||||
import Data.Foldable (traverse_)
|
||||
import Control.Monad (foldM, unless)
|
||||
|
||||
data Error
|
||||
= UndefinedTypeError Identifier
|
||||
| UnexpectedTypeInfoError Info
|
||||
| IdentifierAlreadyDefinedError Identifier
|
||||
| UndefinedSymbolError Identifier
|
||||
| UnexpectedArrayByValue Identifier
|
||||
deriving Eq
|
||||
|
||||
instance Show Error
|
||||
where
|
||||
show (UndefinedTypeError identifier) =
|
||||
concat ["Type \"", show identifier, "\" is not defined"]
|
||||
show (UnexpectedTypeInfoError info) = show info
|
||||
<> " expected to be a type"
|
||||
show (IdentifierAlreadyDefinedError identifier) =
|
||||
concat ["The identifier \"", show identifier, "\" is already defined"]
|
||||
show (UndefinedSymbolError identifier) =
|
||||
concat ["Symbol \"", show identifier, "\" is not defined"]
|
||||
show (UnexpectedArrayByValue identifier) = concat
|
||||
[ "Array \""
|
||||
, show identifier
|
||||
, "\" cannot be passed by value, only by reference"
|
||||
]
|
||||
|
||||
newtype NameAnalysis a = NameAnalysis
|
||||
{ runNameAnalysis :: Except Error a
|
||||
}
|
||||
|
||||
instance Functor NameAnalysis
|
||||
where
|
||||
fmap f (NameAnalysis x) = NameAnalysis $ f <$> x
|
||||
|
||||
instance Applicative NameAnalysis
|
||||
where
|
||||
pure = NameAnalysis . pure
|
||||
(NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x
|
||||
|
||||
instance Monad NameAnalysis
|
||||
where
|
||||
(NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
|
||||
|
||||
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.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
|
||||
|
||||
checkSymbol :: SymbolTable -> Identifier -> NameAnalysis ()
|
||||
checkSymbol globalTable identifier
|
||||
= unless (SymbolTable.member identifier globalTable)
|
||||
$ NameAnalysis $ throwE
|
||||
$ UndefinedSymbolError identifier
|
||||
|
||||
expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
|
||||
expression _ (AST.LiteralExpression _) = pure ()
|
||||
expression globalTable (AST.SumExpression lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
expression globalTable (AST.SubtractionExpression lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
expression globalTable (AST.NegationExpression negation) =
|
||||
expression globalTable negation
|
||||
{- expression globalTable (AST.VariableExpression variableExpression) =
|
||||
variableAccess globalTable variableExpression
|
||||
expression globalTable (AST.ProductExpression lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
expression globalTable (AST.DivisionExpression lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
-}
|
||||
statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
|
||||
statement _ AST.EmptyStatement = pure ()
|
||||
statement globalTable (AST.CallStatement name arguments)
|
||||
= checkSymbol globalTable name
|
||||
>> traverse_ (expression globalTable) arguments
|
||||
{- statement globalTable (AST.AssignmentStatement lvalue rvalue)
|
||||
= variableAccess globalTable lvalue
|
||||
>> expression globalTable rvalue
|
||||
statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
|
||||
= condition globalTable ifCondition
|
||||
>> statement globalTable ifStatement
|
||||
>> maybe (pure ()) (statement globalTable) elseStatement
|
||||
statement globalTable (AST.WhileStatement whileCondition loop)
|
||||
= condition globalTable whileCondition
|
||||
>> statement globalTable loop
|
||||
statement globalTable (AST.CompoundStatement statements) =
|
||||
traverse_ (statement globalTable) statements
|
||||
|
||||
variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis ()
|
||||
variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression)
|
||||
= variableAccess globalTable arrayExpression
|
||||
>> expression globalTable indexExpression
|
||||
variableAccess globalTable (AST.VariableAccess identifier) =
|
||||
checkSymbol globalTable identifier
|
||||
|
||||
condition :: SymbolTable -> AST.Condition -> NameAnalysis ()
|
||||
condition globalTable (AST.EqualCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
condition globalTable (AST.NonEqualCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
condition globalTable (AST.LessCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
condition globalTable (AST.GreaterCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
condition globalTable (AST.LessOrEqualCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
condition globalTable (AST.GreaterOrEqualCondition lhs rhs)
|
||||
= expression globalTable lhs
|
||||
>> expression globalTable rhs
|
||||
|
||||
enter :: Identifier -> Info -> SymbolTable -> NameAnalysis SymbolTable
|
||||
enter identifier info table
|
||||
= maybe (identifierAlreadyDefinedError identifier) pure
|
||||
$ SymbolTable.enter identifier info table
|
||||
|
||||
identifierAlreadyDefinedError :: Identifier -> NameAnalysis a
|
||||
identifierAlreadyDefinedError = NameAnalysis
|
||||
. lift
|
||||
. throwE
|
||||
. IdentifierAlreadyDefinedError
|
||||
|
||||
variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
|
||||
variableDeclaration (AST.VariableDeclaration identifier typeExpression)
|
||||
= (identifier,) . VariableInfo False
|
||||
<$> dataType typeExpression
|
||||
-}
|
||||
223
lib/Language/Elna/Frontend/Parser.hs
Normal file
223
lib/Language/Elna/Frontend/Parser.hs
Normal file
@ -0,0 +1,223 @@
|
||||
module Language.Elna.Frontend.Parser
|
||||
( Parser
|
||||
, programP
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Combinators.Expr (Operator(..), makeExprParser)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Void (Void)
|
||||
import Language.Elna.Frontend.AST
|
||||
( Declaration(..)
|
||||
, Identifier(..)
|
||||
, Parameter(..)
|
||||
, Program(..)
|
||||
, Statement(..)
|
||||
, TypeExpression(..)
|
||||
, VariableDeclaration(..)
|
||||
{-, VariableAccess(..)
|
||||
, Condition(..)-}
|
||||
, Expression(..)
|
||||
, Literal(..)
|
||||
)
|
||||
import Text.Megaparsec
|
||||
( Parsec
|
||||
, (<?>)
|
||||
, MonadParsec(..)
|
||||
, eof
|
||||
, optional
|
||||
, between
|
||||
, sepBy
|
||||
, choice
|
||||
)
|
||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import Text.Megaparsec.Char
|
||||
( alphaNumChar
|
||||
-- , char
|
||||
, letterChar
|
||||
, space1
|
||||
-- , string
|
||||
)
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Data.Maybe (isJust)
|
||||
-- import Data.Functor (($>))
|
||||
|
||||
type Parser = Parsec Void Text
|
||||
|
||||
literalP :: Parser Literal
|
||||
literalP
|
||||
= {- HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal)
|
||||
<|> -} IntegerLiteral <$> Lexer.signed space integerP
|
||||
{- <|> CharacterLiteral <$> lexeme charP
|
||||
<|> BooleanLiteral <$> (symbol "true" $> True)
|
||||
<|> BooleanLiteral <$> (symbol "false" $> False)
|
||||
where
|
||||
charP = fromIntegral . fromEnum
|
||||
<$> between (char '\'') (char '\'') Lexer.charLiteral -}
|
||||
{-
|
||||
typeDefinitionP :: Parser Declaration
|
||||
typeDefinitionP = TypeDefinition
|
||||
<$> (symbol "type" *> identifierP)
|
||||
<*> (symbol "=" *> typeExpressionP)
|
||||
<* semicolonP
|
||||
<?> "type definition"
|
||||
-}
|
||||
termP :: Parser Expression
|
||||
termP = choice
|
||||
[ parensP expressionP
|
||||
, LiteralExpression <$> literalP
|
||||
-- , VariableExpression <$> variableAccessP
|
||||
]
|
||||
|
||||
operatorTable :: [[Operator Parser Expression]]
|
||||
operatorTable =
|
||||
[ unaryOperator
|
||||
-- , factorOperator
|
||||
, termOperator
|
||||
]
|
||||
where
|
||||
unaryOperator =
|
||||
[ prefix "-" NegationExpression
|
||||
, prefix "+" id
|
||||
]
|
||||
{- factorOperator =
|
||||
[ binary "*" ProductExpression
|
||||
, binary "/" DivisionExpression
|
||||
] -}
|
||||
termOperator =
|
||||
[ binary "+" SumExpression
|
||||
, binary "-" SubtractionExpression
|
||||
]
|
||||
prefix name f = Prefix (f <$ symbol name)
|
||||
binary name f = InfixL (f <$ symbol name)
|
||||
|
||||
expressionP :: Parser Expression
|
||||
expressionP = makeExprParser termP operatorTable
|
||||
{-
|
||||
variableAccessP :: Parser VariableAccess
|
||||
variableAccessP = do
|
||||
identifier <- identifierP
|
||||
indices <- many $ bracketsP expressionP
|
||||
pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices
|
||||
|
||||
conditionP :: Parser Condition
|
||||
conditionP = do
|
||||
lhs <- expressionP
|
||||
conditionCons <- choice comparisonOperator
|
||||
conditionCons lhs <$> expressionP
|
||||
where
|
||||
comparisonOperator =
|
||||
[ symbol "<" >> pure LessCondition
|
||||
, symbol "<=" >> pure LessOrEqualCondition
|
||||
, symbol ">" >> pure GreaterCondition
|
||||
, symbol ">=" >> pure GreaterOrEqualCondition
|
||||
, symbol "=" >> pure EqualCondition
|
||||
, symbol "#" >> pure NonEqualCondition
|
||||
]
|
||||
-}
|
||||
symbol :: Text -> Parser Text
|
||||
symbol = Lexer.symbol space
|
||||
|
||||
space :: Parser ()
|
||||
space = Lexer.space space1 (Lexer.skipLineComment "//")
|
||||
$ Lexer.skipBlockComment "/*" "*/"
|
||||
|
||||
lexeme :: forall a. Parser a -> Parser a
|
||||
lexeme = Lexer.lexeme space
|
||||
|
||||
blockP :: forall a. Parser a -> Parser a
|
||||
blockP = between (symbol "{") (symbol "}")
|
||||
|
||||
parensP :: forall a. Parser a -> Parser a
|
||||
parensP = between (symbol "(") (symbol ")")
|
||||
|
||||
bracketsP :: forall a. Parser a -> Parser a
|
||||
bracketsP = between (symbol "[") (symbol "]")
|
||||
|
||||
colonP :: Parser ()
|
||||
colonP = void $ symbol ":"
|
||||
|
||||
commaP :: Parser ()
|
||||
commaP = void $ symbol ","
|
||||
|
||||
semicolonP :: Parser ()
|
||||
semicolonP = void $ symbol ";"
|
||||
|
||||
integerP :: Integral a => Parser a
|
||||
integerP = lexeme Lexer.decimal
|
||||
|
||||
identifierP :: Parser Identifier
|
||||
identifierP =
|
||||
let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier"
|
||||
in fmap Identifier $ lexeme $ Text.pack <$> wordParser
|
||||
|
||||
procedureP :: Parser ()
|
||||
procedureP = void $ symbol "proc"
|
||||
|
||||
parameterP :: Parser Parameter
|
||||
parameterP = paramCons
|
||||
<$> optional (symbol "ref")
|
||||
<*> identifierP
|
||||
<*> (colonP *> typeExpressionP)
|
||||
where
|
||||
paramCons ref name typeName = Parameter name typeName (isJust ref)
|
||||
|
||||
typeExpressionP :: Parser TypeExpression
|
||||
typeExpressionP = arrayTypeExpression
|
||||
<|> NamedType <$> identifierP
|
||||
<?> "type expression"
|
||||
where
|
||||
arrayTypeExpression = ArrayType
|
||||
<$> (symbol "array" *> bracketsP integerP)
|
||||
<*> (symbol "of" *> typeExpressionP)
|
||||
|
||||
procedureDeclarationP :: Parser Declaration
|
||||
procedureDeclarationP = procedureCons
|
||||
<$> (procedureP *> identifierP)
|
||||
<*> parensP (sepBy parameterP commaP)
|
||||
<*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
|
||||
<?> "procedure definition"
|
||||
where
|
||||
procedureCons procedureName parameters (variables, body) =
|
||||
ProcedureDeclaration procedureName parameters variables body
|
||||
|
||||
statementP :: Parser Statement
|
||||
statementP
|
||||
= EmptyStatement <$ semicolonP
|
||||
{-<|> CompoundStatement <$> blockP (many statementP)
|
||||
<|> try assignmentP
|
||||
<|> try ifElseP
|
||||
<|> try whileP -}
|
||||
<|> try callP
|
||||
<?> "statement"
|
||||
where
|
||||
callP = CallStatement
|
||||
<$> identifierP
|
||||
<*> parensP (sepBy expressionP commaP)
|
||||
<* semicolonP
|
||||
{-ifElseP = IfStatement
|
||||
<$> (symbol "if" *> parensP conditionP)
|
||||
<*> statementP
|
||||
<*> optional (symbol "else" *> statementP)
|
||||
whileP = WhileStatement
|
||||
<$> (symbol "while" *> parensP conditionP)
|
||||
<*> statementP
|
||||
assignmentP = AssignmentStatement
|
||||
<$> variableAccessP
|
||||
<* symbol ":="
|
||||
<*> expressionP
|
||||
<* semicolonP -}
|
||||
|
||||
variableDeclarationP :: Parser VariableDeclaration
|
||||
variableDeclarationP = VariableDeclaration
|
||||
<$> (symbol "var" *> identifierP)
|
||||
<*> (colonP *> typeExpressionP)
|
||||
<* semicolonP
|
||||
<?> "variable declaration"
|
||||
|
||||
declarationP :: Parser Declaration
|
||||
declarationP = procedureDeclarationP -- <|> typeDefinitionP
|
||||
|
||||
programP :: Parser Program
|
||||
programP = Program <$> many declarationP <* eof
|
||||
88
lib/Language/Elna/Frontend/SymbolTable.hs
Normal file
88
lib/Language/Elna/Frontend/SymbolTable.hs
Normal file
@ -0,0 +1,88 @@
|
||||
module Language.Elna.Frontend.SymbolTable
|
||||
( SymbolTable
|
||||
, Info(..)
|
||||
, ParameterInfo(..)
|
||||
, builtInSymbolTable
|
||||
, empty
|
||||
, enter
|
||||
, fromList
|
||||
, lookup
|
||||
, member
|
||||
, scope
|
||||
, toMap
|
||||
, update
|
||||
) where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List (sort)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as Vector
|
||||
import Language.Elna.Location (Identifier(..))
|
||||
import Language.Elna.Frontend.Types (Type(..), intType)
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
|
||||
deriving (Eq, Show)
|
||||
|
||||
empty :: SymbolTable
|
||||
empty = SymbolTable Nothing HashMap.empty
|
||||
|
||||
update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable
|
||||
update updater key (SymbolTable parent mappings) = SymbolTable parent
|
||||
$ HashMap.update updater key mappings
|
||||
|
||||
scope :: SymbolTable -> SymbolTable -> SymbolTable
|
||||
scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings
|
||||
|
||||
builtInSymbolTable :: SymbolTable
|
||||
builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList
|
||||
[ ("printi", ProcedureInfo empty Vector.empty)
|
||||
, ("int", TypeInfo intType)
|
||||
]
|
||||
|
||||
toMap :: SymbolTable -> HashMap Identifier Info
|
||||
toMap (SymbolTable _ map') = map'
|
||||
|
||||
enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable
|
||||
enter identifier info table@(SymbolTable parent hashTable)
|
||||
| member identifier table = Nothing
|
||||
| otherwise = Just
|
||||
$ SymbolTable parent (HashMap.insert identifier info hashTable)
|
||||
|
||||
lookup :: Identifier -> SymbolTable -> Maybe Info
|
||||
lookup identifier (SymbolTable parent table)
|
||||
| Just found <- HashMap.lookup identifier table = Just found
|
||||
| Just parent' <- parent = lookup identifier parent'
|
||||
| otherwise = Nothing
|
||||
|
||||
member :: Identifier -> SymbolTable -> Bool
|
||||
member identifier table =
|
||||
isJust $ lookup identifier table
|
||||
|
||||
fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
|
||||
fromList elements
|
||||
| Just identifierDuplicates' <- identifierDuplicates =
|
||||
Left identifierDuplicates'
|
||||
| otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements
|
||||
where
|
||||
identifierDuplicates = NonEmpty.nonEmpty
|
||||
$ fmap NonEmpty.head
|
||||
$ filter ((> 1) . NonEmpty.length)
|
||||
$ NonEmpty.group . sort
|
||||
$ fst <$> elements
|
||||
|
||||
data ParameterInfo = ParameterInfo
|
||||
{ name :: Identifier
|
||||
, type' :: Type
|
||||
, isReferenceParameter :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Info
|
||||
= TypeInfo Type
|
||||
| VariableInfo Bool Type
|
||||
| ProcedureInfo SymbolTable (Vector ParameterInfo)
|
||||
deriving (Eq, Show)
|
||||
186
lib/Language/Elna/Frontend/TypeAnalysis.hs
Normal file
186
lib/Language/Elna/Frontend/TypeAnalysis.hs
Normal file
@ -0,0 +1,186 @@
|
||||
module Language.Elna.Frontend.TypeAnalysis
|
||||
( typeAnalysis
|
||||
, -- Error(..)
|
||||
) where
|
||||
|
||||
import qualified Language.Elna.Frontend.AST as AST
|
||||
import Language.Elna.Frontend.SymbolTable ({-Info(..), ParameterInfo(..), -}SymbolTable)
|
||||
|
||||
typeAnalysis :: SymbolTable -> AST.Program -> () -- Maybe Error
|
||||
typeAnalysis _globalTable = const () {- either Just (const Nothing)
|
||||
. runExcept
|
||||
. flip runReaderT globalTable
|
||||
. runTypeAnalysis
|
||||
. program -}
|
||||
|
||||
{-
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad.Trans.Except (Except, runExcept, throwE)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT, withReaderT, ask)
|
||||
import qualified Data.Vector as Vector
|
||||
import Language.Elna.Location (Identifier(..))
|
||||
import qualified Language.Elna.SymbolTable as SymbolTable
|
||||
import Language.Elna.Types (Type(..), booleanType, intType)
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad (unless, when)
|
||||
import Data.Foldable (traverse_)
|
||||
|
||||
data Error
|
||||
= ArithmeticExpressionError Type
|
||||
| ComparisonExpressionError Type Type
|
||||
| UnexpectedVariableInfoError Info
|
||||
| UnexpectedProcedureInfoError Info
|
||||
| UndefinedSymbolError Identifier
|
||||
| InvalidConditionTypeError Type
|
||||
| InvalidAssignmentError Type
|
||||
| ExpectedLvalueError AST.Expression
|
||||
| ParameterCountMismatchError Int Int
|
||||
| ArgumentTypeMismatchError Type Type
|
||||
| ArrayIndexError Type
|
||||
| ArrayAccessError Type
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype TypeAnalysis a = TypeAnalysis
|
||||
{ runTypeAnalysis :: ReaderT SymbolTable (Except Error) a
|
||||
}
|
||||
|
||||
instance Functor TypeAnalysis
|
||||
where
|
||||
fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x
|
||||
|
||||
instance Applicative TypeAnalysis
|
||||
where
|
||||
pure = TypeAnalysis . pure
|
||||
(TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x
|
||||
|
||||
instance Monad TypeAnalysis
|
||||
where
|
||||
(TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f)
|
||||
|
||||
program :: AST.Program -> TypeAnalysis ()
|
||||
program (AST.Program declarations) = traverse_ declaration declarations
|
||||
|
||||
declaration :: AST.Declaration -> TypeAnalysis ()
|
||||
declaration (AST.ProcedureDefinition procedureName _ _ body) = do
|
||||
globalTable <- TypeAnalysis ask
|
||||
case SymbolTable.lookup procedureName globalTable of
|
||||
Just (ProcedureInfo localTable _) -> TypeAnalysis
|
||||
$ withReaderT (const localTable)
|
||||
$ runTypeAnalysis
|
||||
$ traverse_ (statement globalTable) body
|
||||
Just anotherInfo -> TypeAnalysis $ lift $ throwE
|
||||
$ UnexpectedProcedureInfoError anotherInfo
|
||||
Nothing -> TypeAnalysis $ lift $ throwE
|
||||
$ UndefinedSymbolError procedureName
|
||||
declaration _ = pure ()
|
||||
|
||||
statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
|
||||
statement globalTable = \case
|
||||
AST.EmptyStatement -> pure ()
|
||||
AST.AssignmentStatement lhs rhs -> do
|
||||
lhsType <- variableAccess globalTable lhs
|
||||
rhsType <- expression globalTable rhs
|
||||
unless (lhsType == intType)
|
||||
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
|
||||
unless (rhsType == intType)
|
||||
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
|
||||
AST.IfStatement ifCondition ifStatement elseStatement -> do
|
||||
conditionType <- condition globalTable ifCondition
|
||||
unless (conditionType == booleanType)
|
||||
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
|
||||
statement globalTable ifStatement
|
||||
maybe (pure ()) (statement globalTable) elseStatement
|
||||
AST.WhileStatement whileCondition whileStatement -> do
|
||||
conditionType <- condition globalTable whileCondition
|
||||
unless (conditionType == booleanType)
|
||||
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
|
||||
statement globalTable whileStatement
|
||||
AST.CompoundStatement statements -> traverse_ (statement globalTable) statements
|
||||
AST.CallStatement procedureName arguments ->
|
||||
case SymbolTable.lookup procedureName globalTable of
|
||||
Just (ProcedureInfo _ parameters)
|
||||
| parametersLength <- Vector.length parameters
|
||||
, argumentsLength <- length arguments
|
||||
, Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE
|
||||
$ ParameterCountMismatchError parametersLength argumentsLength
|
||||
| otherwise -> traverse_ (uncurry checkArgument)
|
||||
$ Vector.zip parameters (Vector.fromList arguments)
|
||||
Just anotherInfo -> TypeAnalysis $ lift $ throwE
|
||||
$ UnexpectedVariableInfoError anotherInfo
|
||||
Nothing -> TypeAnalysis $ lift $ throwE
|
||||
$ UndefinedSymbolError procedureName
|
||||
where
|
||||
checkArgument ParameterInfo{..} argument = do
|
||||
argumentType <- expression globalTable argument
|
||||
unless (argumentType == type')
|
||||
$ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
|
||||
when (isReferenceParameter && not (isLvalue argument))
|
||||
$ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument
|
||||
isLvalue (AST.VariableExpression _) = True
|
||||
isLvalue _ = False
|
||||
|
||||
variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type
|
||||
variableAccess globalTable (AST.VariableAccess identifier) = do
|
||||
localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier
|
||||
case localLookup <|> SymbolTable.lookup identifier globalTable of
|
||||
Just (VariableInfo _ variableType) -> pure variableType
|
||||
Just anotherInfo -> TypeAnalysis $ lift $ throwE
|
||||
$ UnexpectedVariableInfoError anotherInfo
|
||||
Nothing -> TypeAnalysis $ lift $ throwE
|
||||
$ UndefinedSymbolError identifier
|
||||
variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do
|
||||
arrayType <- variableAccess globalTable arrayExpression
|
||||
indexType <- expression globalTable indexExpression
|
||||
unless (indexType == intType)
|
||||
$ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType
|
||||
case arrayType of
|
||||
ArrayType _ baseType -> pure baseType
|
||||
nonArrayType -> TypeAnalysis $ lift $ throwE
|
||||
$ ArrayAccessError nonArrayType
|
||||
|
||||
expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type
|
||||
expression globalTable = \case
|
||||
AST.VariableExpression variableExpression -> do
|
||||
variableAccess globalTable variableExpression
|
||||
AST.LiteralExpression literal' -> literal literal'
|
||||
AST.NegationExpression negation -> do
|
||||
operandType <- expression globalTable negation
|
||||
if operandType == intType
|
||||
then pure intType
|
||||
else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType
|
||||
AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs
|
||||
AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs
|
||||
AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs
|
||||
AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs
|
||||
where
|
||||
arithmeticExpression lhs rhs = do
|
||||
lhsType <- expression globalTable lhs
|
||||
unless (lhsType == intType)
|
||||
$ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType
|
||||
rhsType <- expression globalTable rhs
|
||||
unless (rhsType == intType)
|
||||
$ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType
|
||||
pure intType
|
||||
|
||||
condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type
|
||||
condition globalTable = \case
|
||||
AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
AST.LessCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
|
||||
where
|
||||
comparisonExpression lhs rhs = do
|
||||
lhsType <- expression globalTable lhs
|
||||
rhsType <- expression globalTable rhs
|
||||
if lhsType == intType && rhsType == intType
|
||||
then pure booleanType
|
||||
else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType
|
||||
|
||||
literal :: AST.Literal -> TypeAnalysis Type
|
||||
literal (AST.IntegerLiteral _) = pure intType
|
||||
literal (AST.HexadecimalLiteral _) = pure intType
|
||||
literal (AST.CharacterLiteral _) = pure intType
|
||||
literal (AST.BooleanLiteral _) = pure booleanType
|
||||
-}
|
||||
29
lib/Language/Elna/Frontend/Types.hs
Normal file
29
lib/Language/Elna/Frontend/Types.hs
Normal file
@ -0,0 +1,29 @@
|
||||
module Language.Elna.Frontend.Types
|
||||
( Type(..)
|
||||
, addressByteSize
|
||||
, booleanType
|
||||
, intType
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word32)
|
||||
import Language.Elna.Location (showArrayType)
|
||||
|
||||
addressByteSize :: Int
|
||||
addressByteSize = 4
|
||||
|
||||
data Type
|
||||
= PrimitiveType Text Int
|
||||
| ArrayType Word32 Type
|
||||
deriving Eq
|
||||
|
||||
instance Show Type
|
||||
where
|
||||
show (PrimitiveType typeName _) = show typeName
|
||||
show (ArrayType elementCount typeName) = showArrayType elementCount typeName
|
||||
|
||||
intType :: Type
|
||||
intType = PrimitiveType "int" 4
|
||||
|
||||
booleanType :: Type
|
||||
booleanType = PrimitiveType "boolean" 1
|
||||
Reference in New Issue
Block a user