path: root/src/Language/Elna/AST.hs

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"