From be4957ee599e7e14c934e61f3d91354760b38acd Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 21 Jul 2024 16:15:17 +0200 Subject: Initial commit --- src/Language/Elna/AST.hs | 202 ++++++++++++++++++++++++++++++++++++++++++++ src/Language/Elna/Parser.hs | 37 ++++++++ src/Main.hs | 13 +++ 3 files changed, 252 insertions(+) create mode 100644 src/Language/Elna/AST.hs create mode 100644 src/Language/Elna/Parser.hs create mode 100644 src/Main.hs (limited to 'src') diff --git a/src/Language/Elna/AST.hs b/src/Language/Elna/AST.hs new file mode 100644 index 0000000..30c6627 --- /dev/null +++ b/src/Language/Elna/AST.hs @@ -0,0 +1,202 @@ +module Language.Elna.AST + ( ConstantDefinition(..) + , Expression(..) + , Identifier(..) + , Literal(..) + , ProcedureDeclaration(..) + , Program(..) + , Statement(..) + , VariableDeclaration(..) + , TypeName(..) + ) where + +import Data.Int (Int32) +import Data.List (intercalate) +import Data.Word (Word8) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Char (chr) + +newtype Identifier = Identifier { unIdentifier :: Text } + deriving Eq + +instance Show Identifier + where + show (Identifier identifier) = Text.unpack identifier + +data TypeName + = NamedType Identifier + | PointerType TypeName + | ArrayType TypeName Int32 + | ProcedureType [Parameter] + deriving Eq + +instance Show TypeName + where + show (NamedType typeName) = show typeName + show (PointerType typeName) = '^' : show typeName + show (ArrayType typeName elementCount) = concat + [show typeName, "[", show elementCount, "]"] + show (ProcedureType parameters) = "proc" <> showParameters parameters + +data Literal + = StringLiteral Text + | IntegerLiteral Int32 + | CharacterLiteral Word8 + | BooleanLiteral Bool + deriving Eq + +instance Show Literal + where + show (StringLiteral string) = Text.unpack + $ "\"" <> string <> "\"" + show (IntegerLiteral integer) = show integer + show (CharacterLiteral character) = + '\'' : chr (fromEnum character) : ['\''] + show (BooleanLiteral boolean) + | boolean = "true" + | otherwise = "false" + +data Expression + = VariableExpression Identifier + | LiteralExpression Literal + | NegationExpression Expression + | NotExpression Expression + | ReferenceExpression Expression + | DereferenceExpression Expression + | SumExpression Expression Expression + | SubtractionExpression Expression Expression + | ProductExpression Expression Expression + | DivisionExpression Expression Expression + | EqualExpression Expression Expression + | NonEqualExpression Expression Expression + | LessExpression Expression Expression + | GreaterExpression Expression Expression + | LessOrEqualExpression Expression Expression + | GreaterOrEqualExpression Expression Expression + | IfExpression Expression Statement Statement + | LoopExpression Expression Statement + | FieldExpression Expression Identifier + deriving Eq + +instance Show Expression + where + show (VariableExpression variable) = show variable + show (LiteralExpression literal) = show literal + show (NegationExpression negation) = '-' : show negation + show (NotExpression negation) = "not " <> show negation + show (ReferenceExpression reference) = '@' : show reference + show (DereferenceExpression dereference) = show dereference <> "^" + show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs] + show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs] + show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs] + show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs] + show (EqualExpression lhs rhs) = concat [show lhs, " = ", show rhs] + show (NonEqualExpression lhs rhs) = concat [show lhs, " /= ", show rhs] + show (LessExpression lhs rhs) = concat [show lhs, " < ", show rhs] + show (GreaterExpression lhs rhs) = concat [show lhs, " > ", show rhs] + show (LessOrEqualExpression lhs rhs) = concat [show lhs, " <= ", show rhs] + show (GreaterOrEqualExpression lhs rhs) = concat [show lhs, " >= ", show rhs] + show (IfExpression condition if' else') = concat + [ "if ", show condition + , " then " <> show if' + , " else " <> show else' + ] + show (LoopExpression accumulator iteration) = concat + ["loop ", show accumulator, " do ", show iteration] + show (FieldExpression fieldExpression identifier) = + show fieldExpression <> "." <> show identifier + +data Statement + = LetStatement Identifier TypeName Expression + | CompoundStatement [Statement] + | CallStatement Identifier [Expression] + | ExpressionStatement Expression + | BreakStatement Expression + | ContinueStatement Expression + deriving Eq + +instance Show Statement + where + show (LetStatement identifier typeName definition) = concat + ["let ", show identifier, ": ", show typeName, " := ", show definition] + show (CompoundStatement statements) = "begin " + <> intercalate "; " (show <$> statements) <> " end" + show (CallStatement name parameters) = show name <> "(" + <> intercalate ", " (show <$> parameters) <> ")" + show (ExpressionStatement expression) = show expression + show (BreakStatement break') = "break " <> show break' + show (ContinueStatement continue') = "continue " <> show continue' + +data ConstantDefinition = + ConstantDefinition Identifier TypeName Literal + deriving Eq + +instance Show ConstantDefinition + where + show (ConstantDefinition identifier typeName definition) = concat + [show identifier, ": ", show typeName, " := ", show definition, ";"] + +data Parameter = Parameter Identifier TypeName + deriving Eq + +instance Show Parameter + where + show (Parameter identifier typeName) = + show identifier <> ": " <> show typeName + +data ProcedureDeclaration + = ProcedureDeclaration Identifier [Parameter] + | ProcedureDefinition Identifier [Parameter] Bool [ConstantDefinition] Statement + deriving Eq + +instance Show ProcedureDeclaration + where + show (ProcedureDeclaration procedureName parameters) = + "proc " <> show procedureName <> showParameters parameters <> "; extern;" + show (ProcedureDefinition procedureName parameters exports constants body) + = "proc " <> show procedureName <> showParameters parameters <> ";" + <> showAttributes exports + <> showConstants constants + <> show body <> ";" + +data VariableDeclaration + = VariableDeclaration Identifier TypeName + | VariableDefinition Identifier TypeName (Maybe Literal) Bool + deriving Eq + +instance Show VariableDeclaration + where + show (VariableDeclaration identifier typeName) + = show identifier <> ": " <> show typeName <> "; extern;" + show (VariableDefinition identifier typeName initialValue exports) + = show identifier <> ": " <> show typeName + <> maybe "" ((" = " <>) . show) initialValue <> ";" + <> showAttributes exports + +data Program = Program [ConstantDefinition] [VariableDeclaration] [ProcedureDeclaration] Statement + deriving Eq + +instance Show Program + where + show (Program constants globals procedures body) + = showConstants constants <> showVariables globals + <> unlines (show <$> procedures) <> show body <> "." + +showAttributes :: Bool -> String +showAttributes True = " export;" +showAttributes False = "" + +showParameters :: [Parameter] -> String +showParameters parameters = + "(" <> intercalate ", " (show <$> parameters) <> ")" + +showConstants :: [ConstantDefinition] -> String +showConstants constants + | null constants = "" + | otherwise = " const " <> unwords (show <$> constants) <> "\n" + +showVariables :: [VariableDeclaration] -> String +showVariables variables + | null variables = "" + | otherwise = " var " <> unwords (show <$> variables) <> "\n" diff --git a/src/Language/Elna/Parser.hs b/src/Language/Elna/Parser.hs new file mode 100644 index 0000000..bf5b4e5 --- /dev/null +++ b/src/Language/Elna/Parser.hs @@ -0,0 +1,37 @@ +module Language.Elna.Parser + ( Parser + , programP + ) where + +import Control.Monad (void) +import Data.Text (Text) +import Data.Void (Void) +import Language.Elna.AST + ( Statement(..) + , Program(..) + ) +import Text.Megaparsec (Parsec) +import Text.Megaparsec.Char (space1) +import qualified Text.Megaparsec.Char.Lexer as Lexer + +type Parser = Parsec Void Text + +space :: Parser () +space = Lexer.space space1 (Lexer.skipLineComment "//") + $ Lexer.skipBlockComment "{" "}" + +lexeme :: forall a. Parser a -> Parser a +lexeme = Lexer.lexeme space + +symbol :: Text -> Parser Text +symbol = Lexer.symbol space + +beginP :: Parser () +beginP = void $ symbol "begin" + +endP :: Parser () +endP = void $ symbol "end" + +programP :: Parser Program +programP = beginP >> endP >> symbol "." + >> pure (Program mempty mempty mempty $ CompoundStatement mempty) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..bb8be4c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Language.Elna.Parser (programP) +import Text.Megaparsec (runParser, errorBundlePretty) +import qualified Data.Text.IO as Text + +main :: IO () +main = Text.getContents + >>= withParseResult . runParser programP "" + where + withParseResult (Right _) = pure () + withParseResult (Left errorBundle) = + putStr $ errorBundlePretty errorBundle -- cgit v1.2.3