path: root/src/Language/Fiddle/Internal/UnitInterface.hs

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

module Language.Fiddle.Internal.UnitInterface where

import Data.Aeson
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Text
import Data.Word
import GHC.Generics
import Language.Fiddle.Internal.Scopes (Scope)
import qualified Language.Fiddle.Internal.Scopes as Scopes
import Language.Fiddle.Internal.UnitNumbers
import Language.Fiddle.Types (SourceSpan)

data InternalDirectiveExpression
  = InternalDirectiveExpressionNumber String
  | InternalDirectiveExpressionString String
  deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)

-- | Represents a compiler directive that provides configuration for the compiler
--   or its various backends. Directives can adjust the behavior of the compiler
--   or influence the code generation in the backends.
data InternalDirective = InternalDirective
  { -- | Specifies the backend that this directive is intended for. If 'Nothing',
    --   the directive applies globally across all backends.
    internalDirectiveBackend :: Maybe String,
    -- | The key or name of the directive. This identifies the directive's
    --   purpose, such as enabling specific features or setting options.
    internalDirectiveKey :: String,
    -- | The optional value associated with this directive. Some directives
    --   may not require a value (e.g., flags), in which case this field is 'Nothing'.
    internalDirectiveValue :: Maybe InternalDirectiveExpression
  }
  deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)

data QualifiedPath a = QualifiedPath
  { -- | The part of the qualified path that belongs to the package.
    packagePart :: [String],
    -- | The part of the qualified path that belongs to the object.
    objectPart :: [String],
    -- | The part of the qualified path that belongs to a register.
    registerPart :: [String],
    -- | The basename (unqualified path)
    basenamePart :: a
  }
  deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord, Functor)

qualifiedPathToString :: String -> String -> QualifiedPath String -> String
qualifiedPathToString majorSeparator minorSeparator qp =
  intercalate majorSeparator $
    map (intercalate minorSeparator) $
      filter
        (not . null)
        [ packagePart qp,
          objectPart qp,
          registerPart qp,
          [basenamePart qp]
        ]

-- | Turn a QualifiedPath with a string to a String list for scope lookups.
qualifiedPathToList :: QualifiedPath String -> NonEmpty String
qualifiedPathToList (QualifiedPath package obj reg base) =
  NonEmpty.prependList (package ++ obj ++ reg) (NonEmpty.singleton base)

-- | Metadata about an exported value. This includes things like the source
-- location, doc comments and compiler directives associated with the exported
-- symbol.
data Metadata = Metadata
  { -- | Fully-qualified path the the element.
    metadataFullyQualifiedPath :: QualifiedPath String,
    -- | Source location for the exported symbol.
    metadataSourceSpan :: SourceSpan,
    -- | Doc comment associated with the symbol.
    metadataDocComment :: Data.Text.Text,
    -- | List of directives associated with this exported symbol.
    metadataDirectives :: [InternalDirective]
  }
  deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)

-- | Contains a datastructure which represents a FiddleUnit.
--
-- These datastructures contain the exported symobls of a fiddle unit and it's
-- direct dependencies.
data UnitInterface where
  UnitInterface ::
    { rootScope :: Scope String (Metadata, ExportedDecl),
      dependencies :: [FilePath]
    } ->
    UnitInterface
  deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)

insert :: (ExportableDecl d) => d -> UnitInterface -> UnitInterface
insert decl (UnitInterface sc deps) =
  let metadata = getMetadata decl
      path = qualifiedPathToList (metadataFullyQualifiedPath metadata)
   in UnitInterface (Scopes.insertScope path (metadata, toExportedDecl decl) sc) deps

singleton :: (ExportableDecl d) => d -> UnitInterface
singleton decl =
  let path = qualifiedPathToList (metadataFullyQualifiedPath (getMetadata decl))
      metadata = getMetadata decl
   in UnitInterface (Scopes.singleton path (metadata, toExportedDecl decl)) []

instance Semigroup UnitInterface where
  (<>) (UnitInterface s d) (UnitInterface s1 d1) =
    UnitInterface (s <> s1) (d <> d1)

instance Monoid UnitInterface where
  mempty = UnitInterface mempty mempty

-- | Represents an exported package declaration in the syntax tree.
-- This is a higher-level abstraction with metadata detailing the package.
data ExportedPackageDecl where
  ExportedPackageDecl ::
    { -- | Metadata associated with the package.
      exportedPackageMetadata :: Metadata
    } ->
    ExportedPackageDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

-- | Represents an exported location declaration in the syntax tree.
-- Contains metadata and the actual integer value of the location.
data ExportedLocationDecl where
  ExportedLocationDecl ::
    { -- | Metadata associated with the location.
      exportedLocationMetadata :: Metadata,
      -- | The value of the location as an integer.
      exportedLocationValue :: N Address
    } ->
    ExportedLocationDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

-- | Represents an exported bits declaration in the syntax tree.
-- Contains metadata and the size of the bits in a Word32 format.
data ExportedBitsDecl where
  ExportedBitsDecl ::
    { -- | Metadata associated with the bits declaration.
      exportedBitsDeclMetadata :: Metadata,
      -- | The size of the bits in this declaration.
      exportedBitsDeclSizeBits :: N Bits
    } ->
    ExportedBitsDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

-- | Represents an exported type declaration in the syntax tree.
-- Contains metadata and the size of the type in bytes.
data ExportedTypeDecl where
  ExportedTypeDecl ::
    { -- | Metadata associated with the type declaration.
      exportedTypeDeclMetadata :: Metadata,
      -- | The size of the type in bytes.
      exportedTypeDeclSizeBytes :: N Bytes
    } ->
    ExportedTypeDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

data ReferencedObjectType where
  ReferencedObjectType ::
    {objectTypeReference :: QualifiedPath String} -> ReferencedObjectType
  ArrayObjectType ::
    { arrayObjectTypeType :: ReferencedObjectType,
      arrayObjectTypeNumber :: N Unitless
    } ->
    ReferencedObjectType
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

-- | Represents an exported object declaration in the syntax tree.
-- This includes metadata, location, and the type of the object.
data ExportedObjectDecl where
  ExportedObjectDecl ::
    { -- | Metadata associated with the object declaration.
      exportedObjectDeclMetadata :: Metadata,
      -- | The memory location of the object.
      exportedObjectDeclLocation :: N Address,
      -- | The type of the object as a string.
      exportedObjectDeclType :: ReferencedObjectType
    } ->
    ExportedObjectDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)

-- | A typeclass for converting various exported declarations into the
-- generalized 'ExportedDecl' type. This allows treating different exported
-- declarations uniformly in the compilation process.
class ExportableDecl a where
  toExportedDecl :: a -> ExportedDecl
  fromExportedDecl :: ExportedDecl -> Maybe a
  getMetadata :: a -> Metadata

-- Instances of 'ExportableDecl' to convert specific exported declaration types
-- into the generalized 'ExportedDecl' type.
instance ExportableDecl ExportedPackageDecl where
  toExportedDecl = ExportedPackage
  fromExportedDecl = \case
    ExportedPackage x -> Just x
    _ -> Nothing
  getMetadata = exportedPackageMetadata

instance ExportableDecl ExportedLocationDecl where
  toExportedDecl = ExportedLocation
  fromExportedDecl = \case
    ExportedLocation x -> Just x
    _ -> Nothing
  getMetadata = exportedLocationMetadata

instance ExportableDecl ExportedBitsDecl where
  toExportedDecl = ExportedBits
  fromExportedDecl = \case
    ExportedBits x -> Just x
    _ -> Nothing
  getMetadata = exportedBitsDeclMetadata

instance ExportableDecl ExportedTypeDecl where
  toExportedDecl = ExportedType
  fromExportedDecl = \case
    ExportedType x -> Just x
    _ -> Nothing
  getMetadata = exportedTypeDeclMetadata

instance ExportableDecl ExportedObjectDecl where
  toExportedDecl = ExportedObject
  fromExportedDecl = \case
    ExportedObject x -> Just x
    _ -> Nothing
  getMetadata = exportedObjectDeclMetadata

instance ExportableDecl ExportedDecl where
  toExportedDecl = id
  fromExportedDecl = Just
  getMetadata =
    \case
      ExportedPackage e -> getMetadata e
      ExportedLocation e -> getMetadata e
      ExportedBits e -> getMetadata e
      ExportedType e -> getMetadata e
      ExportedObject e -> getMetadata e

-- | A generalized representation of different exported declarations.
-- This data type allows for a uniform way to handle various exportable
-- syntax tree elements (e.g., packages, locations, bits, types, objects).
data ExportedDecl where
  ExportedPackage :: ExportedPackageDecl -> ExportedDecl
  ExportedLocation :: ExportedLocationDecl -> ExportedDecl
  ExportedBits :: ExportedBitsDecl -> ExportedDecl
  ExportedType :: ExportedTypeDecl -> ExportedDecl
  ExportedObject :: ExportedObjectDecl -> ExportedDecl
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)