Split in lib and tests

This commit is contained in:
Eugen Wissner 2024-07-23 22:44:42 +02:00
parent 01398f48bf
commit 9d1f038594
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
7 changed files with 377 additions and 316 deletions

View File

@ -15,19 +15,49 @@ build-type: Simple
extra-doc-files: TODO README extra-doc-files: TODO README
common warnings common warnings
ghc-options: -Wall
executable elna
import: warnings
main-is: Main.hs
other-modules:
Language.Elna.AST
Language.Elna.Parser
default-extensions:
OverloadedStrings
build-depends: build-depends:
base ^>=4.17.2.1, base ^>=4.17.2.1,
megaparsec ^>= 9.6, megaparsec ^>= 9.6,
text ^>= 2.0 text ^>= 2.0
hs-source-dirs: src ghc-options: -Wall
default-extensions:
ExplicitForAll,
OverloadedStrings
library elna-internal
import: warnings
exposed-modules:
Language.Elna.AST
Language.Elna.Parser
build-depends:
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 default-language: GHC2021

170
lib/Language/Elna/AST.hs Normal file
View File

@ -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) <> ")"

107
lib/Language/Elna/Parser.hs Normal file
View File

@ -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

View File

@ -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"

View File

@ -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)

View File

@ -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"

1
tests/Spec.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}