elna/lib/Language/Elna/Frontend/AST.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

module Language.Elna.Frontend.AST
    ( Declaration(..)
    , Identifier(..)
    , Parameter(..)
    , Program(..)
    , Statement(..)
    , TypeExpression(..)
    , VariableDeclaration(..)
    , VariableAccess(..)
    , Condition(..)
    , Expression(..)
    , Literal(..)
    ) where

import Data.Char (chr)
import Data.Int (Int32)
import Data.List (intercalate)
import Data.Word (Word8)
import Language.Elna.Location (Identifier(..), showArrayType)
import Numeric (showHex)
import Data.Bifunctor (Bifunctor(bimap))

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 Literal TypeExpression
    deriving Eq

instance Show TypeExpression
  where
    show (NamedType typeName) = show typeName
    show (ArrayType elementCount typeName) =
        showArrayType elementCount typeName

data Statement
    = EmptyStatement
    | IfStatement Condition Statement (Maybe Statement)
    | AssignmentStatement VariableAccess Expression
    | WhileStatement Condition Statement
    | CompoundStatement [Statement]
    | CallStatement Identifier [Expression]
    deriving Eq

instance Show Statement
  where
    show EmptyStatement = ";"
    show (IfStatement condition if' else') = concat
        [ "if (", show condition, ") "
        , show if'
        , maybe "" ((<> " else ") . show) else'
        ]
    show (AssignmentStatement lhs rhs) =
        concat [show lhs, " := ", show rhs, ";"]
    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

data Literal
    = DecimalLiteral Int32
    | HexadecimalLiteral Int32
    | CharacterLiteral Word8
    deriving Eq

instance Show Literal
  where
    show (DecimalLiteral integer) = show integer
    show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
    show (CharacterLiteral character) =
        '\'' : chr (fromEnum character) : ['\'']

instance Ord Literal
  where
    compare x y = compare (int32Literal x) (int32Literal y)

instance Num Literal
  where
    x + y = DecimalLiteral $ int32Literal x + int32Literal y
    x * y = DecimalLiteral $ int32Literal x * int32Literal y
    abs (DecimalLiteral x) = DecimalLiteral $ abs x
    abs (HexadecimalLiteral x) = HexadecimalLiteral $ abs x
    abs (CharacterLiteral x) = CharacterLiteral $ abs x
    negate (DecimalLiteral x) = DecimalLiteral $ negate x
    negate (HexadecimalLiteral x) = HexadecimalLiteral $ negate x
    negate (CharacterLiteral x) = CharacterLiteral $ negate x
    signum (DecimalLiteral x) = DecimalLiteral $ signum x
    signum (HexadecimalLiteral x) = HexadecimalLiteral $ signum x
    signum (CharacterLiteral x) = CharacterLiteral $ signum x
    fromInteger = DecimalLiteral . fromInteger

instance Real Literal
  where
    toRational (DecimalLiteral integer) = toRational integer
    toRational (HexadecimalLiteral integer) = toRational integer
    toRational (CharacterLiteral integer) = toRational integer

instance Enum Literal
  where
   toEnum = DecimalLiteral . fromIntegral
   fromEnum = fromEnum . int32Literal

instance Integral Literal
  where
    toInteger = toInteger . int32Literal
    quotRem x y = bimap DecimalLiteral DecimalLiteral
        $ quotRem (int32Literal x) (int32Literal y)

int32Literal :: Literal -> Int32
int32Literal (DecimalLiteral integer) = integer
int32Literal (HexadecimalLiteral integer) = integer
int32Literal (CharacterLiteral integer) = fromIntegral integer

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
    | ProductExpression Expression Expression
    | DivisionExpression Expression Expression
    | VariableExpression VariableAccess
    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 (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
    show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs]
    show (VariableExpression variable) = show variable

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]