diff options
| -rw-r--r-- | elna.cabal | 50 | ||||
| -rw-r--r-- | lib/Language/Elna/AST.hs | 170 | ||||
| -rw-r--r-- | lib/Language/Elna/Parser.hs | 107 | ||||
| -rw-r--r-- | src/Language/Elna/AST.hs | 268 | ||||
| -rw-r--r-- | src/Language/Elna/Parser.hs | 37 | ||||
| -rw-r--r-- | tests/Language/Elna/ParserSpec.hs | 58 | ||||
| -rw-r--r-- | tests/Spec.hs | 1 |
7 files changed, 376 insertions, 315 deletions
@@ -15,19 +15,49 @@ build-type: Simple extra-doc-files: TODO README common warnings + build-depends: + base ^>=4.17.2.1, + megaparsec ^>= 9.6, + text ^>= 2.0 ghc-options: -Wall + default-extensions: + ExplicitForAll, + OverloadedStrings -executable elna - import: warnings - main-is: Main.hs - other-modules: +library elna-internal + import: warnings + exposed-modules: Language.Elna.AST Language.Elna.Parser - default-extensions: - OverloadedStrings build-depends: - base ^>=4.17.2.1, - megaparsec ^>= 9.6, - text ^>= 2.0 - hs-source-dirs: src + vector >= 0.12 && < 0.14 + hs-source-dirs: lib + +executable elna + import: warnings + main-is: Main.hs + build-depends: + elna-internal + hs-source-dirs: src + default-language: GHC2021 + +test-suite elna-test + import: warnings + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Language.Elna.ParserSpec + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + + build-depends: + elna-internal, + hspec >= 2.10.9 && < 2.12, + hspec-expectations ^>= 0.8.2, + hspec-megaparsec ^>= 2.2.0, + text, + vector + build-tool-depends: + hspec-discover:hspec-discover default-language: GHC2021 diff --git a/lib/Language/Elna/AST.hs b/lib/Language/Elna/AST.hs new file mode 100644 index 0000000..fc4b264 --- /dev/null +++ b/lib/Language/Elna/AST.hs @@ -0,0 +1,170 @@ +module Language.Elna.AST + ( Declaration(..) + , Expression(..) + , Identifier(..) + , Literal(..) + , Parameter(..) + , Program(..) + , Statement(..) + , VariableDeclaration(..) + , TypeExpression(..) + ) 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) +import Data.String (IsString(..)) + +newtype Identifier = Identifier { unIdentifier :: Text } + deriving Eq + +instance Show Identifier + where + show (Identifier identifier) = Text.unpack identifier + +instance IsString Identifier + where + fromString = Identifier . Text.pack + +data TypeExpression + = NamedType Identifier + | ArrayType TypeExpression Int32 + deriving Eq + +instance Show TypeExpression + where + show (NamedType typeName) = show typeName + show (ArrayType typeName elementCount) = concat + [show typeName, "[", show elementCount, "]"] + +data Literal + = IntegerLiteral Int32 + | HexadecimalLiteral Int32 + | CharacterLiteral Word8 + | BooleanLiteral Bool + deriving Eq + +instance Show Literal + where + show (IntegerLiteral integer) = show integer + show (HexadecimalLiteral 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 + | 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 (FieldExpression fieldExpression identifier) = + show fieldExpression <> "." <> show identifier + +data Statement + = EmptyStatement + | AssignmentStatement Expression Expression + | IfStatement Expression Statement (Maybe Statement) + | WhileStatement Expression Statement + | CompoundStatement [Statement] + | CallStatement Identifier [Expression] + deriving Eq + +instance Show Statement + where + show EmptyStatement = ";" + show (AssignmentStatement lhs rhs) = + concat [show lhs, " := ", show rhs, 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) = "begin " + <> intercalate "; " (show <$> statements) <> " end" + show (CallStatement name parameters) = show name <> "(" + <> intercalate ", " (show <$> parameters) <> ")" + +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 + ] + +data VariableDeclaration = + VariableDeclaration Identifier TypeExpression + deriving Eq + +instance Show VariableDeclaration + where + show (VariableDeclaration identifier typeExpression) = + concat [" var ", show identifier, ": " <> show typeExpression, ";"] + +data Declaration + = TypeDefinition Identifier TypeExpression + | ProcedureDefinition Identifier [Parameter] [VariableDeclaration] [Statement] + deriving Eq + +instance Show Declaration + where + show (TypeDefinition identifier typeExpression) = + concat ["type ", show identifier, " = ", show typeExpression] + show (ProcedureDefinition procedureName parameters variables body) + = "proc " <> show procedureName <> showParameters parameters <> ";" + <> unlines (show <$> variables) + <> unlines (show <$> body) <> ";" + +newtype Program = Program [Declaration] + deriving Eq + +instance Show Program + where + show (Program declarations) = unlines (show <$> declarations) + +showParameters :: [Parameter] -> String +showParameters parameters = + "(" <> intercalate ", " (show <$> parameters) <> ")" diff --git a/lib/Language/Elna/Parser.hs b/lib/Language/Elna/Parser.hs new file mode 100644 index 0000000..cd8f927 --- /dev/null +++ b/lib/Language/Elna/Parser.hs @@ -0,0 +1,107 @@ +module Language.Elna.Parser + ( Parser + , programP + ) where + +import Control.Monad (void) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Void (Void) +import Language.Elna.AST + ( Declaration(..) + , Identifier(..) + , Parameter(..) + , Program(..) + , TypeExpression(..) + , VariableDeclaration(..) + ) +import Text.Megaparsec (Parsec, (<?>), optional, between, sepBy) +import Text.Megaparsec.Char (alphaNumChar, letterChar, space1) +import qualified Text.Megaparsec.Char.Lexer as Lexer +import Control.Applicative (Alternative(..)) +import Data.Maybe (isJust) + +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 + +blockP :: forall a. Parser a -> Parser a +blockP = between (symbol "{") (symbol "}") + +procedureP :: Parser () +procedureP = void $ symbol "proc" + +parensP :: forall a. Parser a -> Parser a +parensP = between (symbol "(") (symbol ")") + +openBracketP :: Parser () +openBracketP = void $ symbol "[" + +closingBracketP :: Parser () +closingBracketP = void $ symbol "]" + +colonP :: Parser () +colonP = void $ symbol ":" + +semicolonP :: Parser () +semicolonP = void $ symbol ";" + +identifierP :: Parser Identifier +identifierP = + let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier" + in fmap Identifier $ lexeme $ Text.pack <$> wordParser + +typeExpressionP :: Parser TypeExpression +typeExpressionP = arrayTypeExpression + <|> NamedType <$> identifierP + <?> "type expression" + where + arrayTypeExpression = flip ArrayType + <$> (symbol "array" *> openBracketP *> lexeme Lexer.decimal <* closingBracketP) + <*> (symbol "of" *> typeExpressionP) + +typeDefinitionP :: Parser Declaration +typeDefinitionP = TypeDefinition + <$> (symbol "type" *> identifierP) + <*> (symbol "=" *> typeExpressionP) + <?> "type definition" + +variableDeclarationP :: Parser VariableDeclaration +variableDeclarationP = VariableDeclaration + <$> (symbol "var" *> identifierP) + <*> (colonP *> typeExpressionP) + <* semicolonP + <?> "variable declaration" + +parameterP :: Parser Parameter +parameterP = paramCons + <$> optional (symbol "ref") + <*> identifierP + <*> (colonP *> typeExpressionP) + where + paramCons ref name typeName = Parameter name typeName (isJust ref) + +parametersP :: Parser [Parameter] +parametersP = parensP $ sepBy parameterP (symbol ",") + +procedureDefinitionP :: Parser Declaration +procedureDefinitionP = ProcedureDefinition + <$> (procedureP *> identifierP) + <*> parametersP + <*> blockP (many variableDeclarationP) + <*> pure mempty -- TODO + <?> "procedure definition" + +declarationP :: Parser Declaration +declarationP = typeDefinitionP <|> procedureDefinitionP + +programP :: Parser Program +programP = Program <$> many declarationP diff --git a/src/Language/Elna/AST.hs b/src/Language/Elna/AST.hs deleted file mode 100644 index 0ac8eb5..0000000 --- a/src/Language/Elna/AST.hs +++ /dev/null @@ -1,268 +0,0 @@ -module Language.Elna.AST - ( ConstantDefinition(..) - , Declaration(..) - , Expression(..) - , Identifier(..) - , Literal(..) - , ProcedureDeclaration(..) - , Program(..) - , Statement(..) - , VariableDeclaration(..) - , TypeDefinition(..) - , TypeName(..) - ) where - -import Data.Int (Int32) -import Data.List (intercalate) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -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 - | ByteLiteral Word8 - | CharacterLiteral Word8 - | BooleanLiteral Bool - | RecordLiteral (NonEmpty Argument) - | VariantLiteral (NonEmpty Argument) - | EnumLiteral Identifier - deriving Eq - -instance Show Literal - where - show (StringLiteral string) = Text.unpack - $ "\"" <> string <> "\"" - show (IntegerLiteral integer) = show integer - show (ByteLiteral word) = show word - show (CharacterLiteral character) = - '\'' : chr (fromEnum character) : ['\''] - show (BooleanLiteral boolean) - | boolean = "true" - | otherwise = "false" - show (RecordLiteral arguments) = showArguments arguments - show (VariantLiteral arguments) = showArguments arguments - show (EnumLiteral identifier) = show identifier - -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 Identifier 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 identifier accumulator iteration) = concat - [ "loop ", show identifier - , " := ", 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 Argument = Argument Identifier Literal - deriving Eq - -instance Show Argument - where - show (Argument identifier value) = - concat [show identifier, ": ", show value] - -data ProcedureDeclaration - = ExternProcedureDeclaration Identifier [Parameter] - | ProcedureDefinition Identifier [Parameter] Bool [ConstantDefinition] Statement - deriving Eq - -instance Show ProcedureDeclaration - where - show (ExternProcedureDeclaration 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 - = ExternVariableDeclaration Identifier TypeName - | VariableDefinition Identifier TypeName (Maybe Literal) Bool - deriving Eq - -instance Show VariableDeclaration - where - show (ExternVariableDeclaration identifier typeName) - = show identifier <> ": " <> show typeName <> "; extern;" - show (VariableDefinition identifier typeName initialValue exports) - = show identifier <> ": " <> show typeName - <> maybe "" ((" = " <>) . show) initialValue <> ";" - <> showAttributes exports - -data TypeDefinition - = RecordDefinition Identifier (NonEmpty Parameter) - | VariantDefinition Identifier (NonEmpty Parameter) - | EnumerationDefinition Identifier (NonEmpty Identifier) - deriving Eq - -instance Show TypeDefinition - where - show (RecordDefinition identifier fields) = show identifier - <> " = record " <> intercalate "; " (NonEmpty.toList $ show <$> fields) - <> " end;" - show (VariantDefinition identifier fields) = show identifier - <> " = variant " <> intercalate "; " (NonEmpty.toList $ show <$> fields) - <> " end;" - show (EnumerationDefinition identifier members) = show identifier <> " = (" - <> intercalate ", " (NonEmpty.toList $ show <$> members) <> ");" - -data Declaration - = TypeDeclaration TypeDefinition - | ConstantDeclaration ConstantDefinition - | VariableDeclaration VariableDeclaration - | ProcedureDeclaration ProcedureDeclaration - deriving Eq - -instance Show Declaration - where - show (TypeDeclaration typeDefinition) = show typeDefinition - show (ConstantDeclaration constantDefinition) = show constantDefinition - show (VariableDeclaration variableDeclaration) = show variableDeclaration - show (ProcedureDeclaration procedureDeclaration) = show procedureDeclaration - -data Program = Program [Declaration] Statement - deriving Eq - -instance Show Program - where - show (Program declarations body) = - let declarations' = foldr showDeclaration ("", []) declarations - in unlines (snd declarations') <> show body <> "." - where - showDeclaration :: Declaration -> (String, [String]) -> (String, [String]) - showDeclaration (TypeDeclaration typeDeclaration) (previous, accumulator) - | previous == "type" = ("type", show typeDeclaration : accumulator) - | otherwise = ("type", "type " <> show typeDeclaration : accumulator) - showDeclaration (ConstantDeclaration constantDeclaration) (previous, accumulator) - | previous == "const" = ("const", show constantDeclaration : accumulator) - | otherwise = ("const", "const " <> show constantDeclaration : accumulator) - showDeclaration (VariableDeclaration variableDeclaration) (previous, accumulator) - | previous == "var" = ("var", show variableDeclaration : accumulator) - | otherwise = ("var", "var " <> show variableDeclaration : accumulator) - showDeclaration (ProcedureDeclaration procedureDeclaration) (_previous, accumulator) = - ("proc", show procedureDeclaration : accumulator) - -showAttributes :: Bool -> String -showAttributes True = " export;" -showAttributes False = "" - -showParameters :: [Parameter] -> String -showParameters parameters = - "(" <> intercalate ", " (show <$> parameters) <> ")" - -showArguments :: NonEmpty Argument -> String -showArguments arguments = - "(" <> intercalate "; " (NonEmpty.toList $ show <$> arguments) <> ")" - -showConstants :: [ConstantDefinition] -> String -showConstants constants - | null constants = "" - | otherwise = " const " <> unwords (show <$> constants) <> "\n" diff --git a/src/Language/Elna/Parser.hs b/src/Language/Elna/Parser.hs deleted file mode 100644 index 87ebc44..0000000 --- a/src/Language/Elna/Parser.hs +++ /dev/null @@ -1,37 +0,0 @@ -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 $ CompoundStatement mempty) diff --git a/tests/Language/Elna/ParserSpec.hs b/tests/Language/Elna/ParserSpec.hs new file mode 100644 index 0000000..11907ab --- /dev/null +++ b/tests/Language/Elna/ParserSpec.hs @@ -0,0 +1,58 @@ +module Language.Elna.ParserSpec + ( spec + ) where + +import Test.Hspec (Spec, describe, it, pendingWith, xit) +import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn, parseSatisfies) +import Language.Elna.Parser (programP) +import Text.Megaparsec (parse) +import Language.Elna.AST + ( Declaration(..) + , Parameter(..) + , Program(..) + , TypeExpression(..) + ) + +spec :: Spec +spec = + describe "programP" $ do + it "parses an empty main function" $ + parse programP "" `shouldSucceedOn` "proc main() {}" + + it "parses type definition for a type starting like array" $ + let expected = Program [TypeDefinition "t" $ NamedType "arr"] + actual = parse programP "" "type t = arr" + in actual `shouldParse` expected + + it "parses array type definition" $ + let expected = Program [TypeDefinition "t" $ ArrayType (NamedType "integer") 10] + actual = parse programP "" "type t = array[10] of integer" + in actual `shouldParse` expected + + it "parses parameters" $ + let given = "proc main(x: integer) {}" + parameters = [Parameter "x" (NamedType "integer") False] + expected = Program [ProcedureDefinition "main" parameters [] []] + actual = parse programP "" given + in actual `shouldParse` expected + + it "parses ref parameters" $ + let given = "proc main(x: integer, ref y: boolean) {}" + parameters = + [ Parameter "x" (NamedType "integer") False + , Parameter "y" (NamedType "boolean") True + ] + expected = Program [ProcedureDefinition "main" parameters [] []] + actual = parse programP "" given + in actual `shouldParse` expected + + it "parses variable declaration" $ + let given = "proc main() { var x: integer; }" + expected (Program [ProcedureDefinition _ _ variables _]) = + not $ null variables + expected _ = False + actual = parse programP "" given + in actual `parseSatisfies` expected + + it "parses procedure body statements" $ + pendingWith "Not implemented" diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} |