2 files changed, 177 insertions, 42 deletions

diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index 70cadee..c232328 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -2,20 +2,22 @@
 
 module Language.Fiddle.Internal.Scopes where
 
+import Data.Foldable
 import Data.Aeson
 import Data.Aeson.Key
 import Data.List (inits)
 import Data.List.NonEmpty (NonEmpty (..), prependList)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
+import Control.Arrow (Arrow(first))
 
 -- | 'Scope' represents a hierarchical structure for storing key-value pairs.
 --   It can contain nested sub-scopes, which are stored in 'subScopes',
 --   and the values for a specific scope are stored in 'scopeValues'.
 data Scope k v = Scope
   { subScopes :: Map k (Scope k v), -- Nested sub-scopes
-    scopeValues :: Map k v -- Values stored in the current scope
+    scopeValues :: Map k [v] -- Values stored in the current scope
   }
   deriving (Eq, Ord, Show, Read, Functor, Foldable)
 
@@ -29,24 +31,24 @@ data ScopePath k = ScopePath
   deriving (Eq, Ord, Show, Read)
 
 -- | Qualify a name with the current scope.
-qualifyPath :: ScopePath k -> k -> [k]
-qualifyPath ScopePath {currentScope = scope} k = scope ++ [k]
+qualifyPath :: ScopePath k -> NonEmpty k -> NonEmpty k
+qualifyPath ScopePath {currentScope = scope} = prependList scope
 
 -- | Push a new scope onto the current scope.
-pushScope :: k -> ScopePath k -> ScopePath k
+pushScope :: NonEmpty k -> ScopePath k -> ScopePath k
 pushScope v s@ScopePath {currentScope = scope} =
-  s {currentScope = scope ++ [v]}
+  s {currentScope = scope ++ toList v}
 
 -- | Adds a path to the "using" paths.
-addUsingPath :: [k] -> ScopePath k -> ScopePath k
+addUsingPath :: NonEmpty k -> ScopePath k -> ScopePath k
 addUsingPath path s@ScopePath {usingPaths = paths} =
-  s {usingPaths = path : paths}
+  s {usingPaths = toList path : paths}
 
 -- | The 'Semigroup' instance for 'Scope' allows combining two scopes,
 --   where sub-scopes and values are merged together.
 instance (Ord k) => Semigroup (Scope k t) where
   (Scope ss1 sv1) <> (Scope ss2 sv2) =
-    Scope (Map.unionWith (<>) ss1 ss2) (Map.union sv1 sv2)
+    Scope (Map.unionWith (<>) ss1 ss2) (Map.unionWith (<>) sv1 sv2)
 
 -- | The 'Monoid' instance for 'Scope' provides an empty scope with
 --   no sub-scopes or values.
@@ -71,9 +73,10 @@ instance Monoid (ScopePath k) where
 --   This function effectively performs an "insert-or-update" operation, allowing
 --   you to upsert values into nested scopes while tracking any existing value
 --   that was replaced.
-upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> (Maybe t, Scope k t)
+upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> ([t], Scope k t)
 upsertScope (s :| []) v (Scope ss sv) =
-  Scope ss <$> Map.insertLookupWithKey (\_ n _ -> n) s v sv
+  first (fromMaybe []) $
+    Scope ss <$> Map.insertLookupWithKey (const (<>)) s [v] sv
 upsertScope (s :| (a : as)) v (Scope ss sv) =
   let subscope = fromMaybe mempty (Map.lookup s ss)
       (replaced, subscope') = upsertScope (a :| as) v subscope
@@ -82,15 +85,18 @@ upsertScope (s :| (a : as)) v (Scope ss sv) =
 insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
 insertScope p s = snd . upsertScope p s
 
+singleton :: (Ord k) => NonEmpty k -> t -> Scope k t
+singleton ks t = insertScope ks t mempty
+
 -- insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
 -- insertScope a b = snd . upsertScope a b
 
 -- | 'lookupScope' performs a lookup of a value in the scope using a key path
 --   ('NonEmpty k'). It traverses through sub-scopes as defined by the path.
-lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> Maybe t
-lookupScope (s :| []) (Scope _ sv) = Map.lookup s sv
+lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> [t]
+lookupScope (s :| []) (Scope _ sv) = fromMaybe [] $ Map.lookup s sv
 lookupScope (s :| (a : as)) (Scope ss _) = do
-  subscope <- Map.lookup s ss
+  subscope <- maybeToList $ Map.lookup s ss
   lookupScope (a :| as) subscope
 
 -- | 'lookupScopeWithPath' searches for a key in the scope by trying all possible
@@ -122,10 +128,16 @@ lookupScopeWithPath ::
   [(NonEmpty k, t)]
 lookupScopeWithPath (ScopePath current others) key scope =
   let allPaths = reverse (inits current) ++ others
-   in flip concatMap allPaths $ \prefix -> do
-        case lookupScope (prependList prefix key) scope of
-          Just s -> [(prependList prefix key, s)]
-          Nothing -> []
+   in do
+        prefix <- allPaths
+        let qualifiedKey = prependList prefix key
+        value <- lookupScope qualifiedKey scope
+        return (qualifiedKey, value)
+
+-- flip concatMap allPaths $ \prefix -> do
+--      case lookupScope (prependList prefix key) scope of
+--        Just s -> [(prependList prefix key, s)]
+--        Nothing -> []
 
 instance (ToJSONKey k, ToJSON v, Ord k) => ToJSON (Scope k v) where
   toJSON scope =
diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs
index aacb71d..c5cbc2c 100644
--- a/src/Language/Fiddle/Internal/UnitInterface.hs
+++ b/src/Language/Fiddle/Internal/UnitInterface.hs
@@ -1,14 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Language.Fiddle.Internal.UnitInterface where
 
 import Data.Aeson
+import Data.List.NonEmpty (NonEmpty)
 import 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.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.
@@ -21,7 +26,7 @@ data InternalDirective = InternalDirective
     directiveKey :: 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'.
-    directiveValue :: Maybe String
+    directiveValue :: Maybe InternalDirectiveExpression
   }
   deriving (Generic, ToJSON, FromJSON, Show, Eq, Ord)
 
@@ -29,7 +34,9 @@ data InternalDirective = InternalDirective
 -- location, doc comments and compiler directives associated with the exported
 -- symbol.
 data Metadata = Metadata
-  { -- | Source location for the exported symbol.
+  { -- | Fully-qualified path the the element.
+    metadataFullyQualifiedPath :: NonEmpty String,
+    -- | Source location for the exported symbol.
     metadataSourceSpan :: SourceSpan,
     -- | Doc comment associated with the symbol.
     metadataDocComment :: Text,
@@ -44,11 +51,23 @@ data Metadata = Metadata
 -- direct dependencies.
 data UnitInterface where
   UnitInterface ::
-    { rootScope :: Scope String (Metadata, ExportedValue),
+    { rootScope :: Scope String (Metadata, ExportedDecl),
       dependencies :: [FilePath]
     } ->
     UnitInterface
-  deriving (Eq, Ord, Show)
+  deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
+
+insert :: (ExportableDecl d) => d -> UnitInterface -> UnitInterface
+insert decl (UnitInterface sc deps) =
+  let metadata = getMetadata decl
+      path = metadataFullyQualifiedPath metadata
+   in UnitInterface (Scopes.insertScope path (metadata, toExportedDecl decl) sc) deps
+
+singleton :: (ExportableDecl d) => d -> UnitInterface
+singleton decl =
+  let path = metadataFullyQualifiedPath (getMetadata decl)
+      metadata = getMetadata decl
+   in UnitInterface (Scopes.singleton path (metadata, toExportedDecl decl)) []
 
 instance Semigroup UnitInterface where
   (<>) (UnitInterface s d) (UnitInterface s1 d1) =
@@ -57,24 +76,128 @@ instance Semigroup UnitInterface where
 instance Monoid UnitInterface where
   mempty = UnitInterface mempty mempty
 
-data ExportedValue where
-  ExportedBitsType ::
-    {exportBitsTypeSize :: Word32} ->
-    ExportedValue
-  ExportedObjType ::
-    {exportObjTypeSize :: Word32} ->
-    ExportedValue
+-- | 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 :: Integer
+    } ->
+    ExportedLocationDecl
   deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
 
-instance ToJSON UnitInterface where
-  toJSON ui =
-    object
-      [ "rootScope" .= rootScope ui,
-        "dependencies" .= dependencies ui
-      ]
+-- | 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 :: Word32
+    } ->
+    ExportedBitsDecl
+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
 
-instance FromJSON UnitInterface where
-  parseJSON = withObject "UnitInterface" $ \v ->
-    UnitInterface
-      <$> v .: "rootScope"
-      <*> v .: "dependencies"
+-- | 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 :: Word32
+    } ->
+    ExportedTypeDecl
+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
+
+data ReferencedObjectType where
+  ReferencedObjectType ::
+    {objectTypeReference :: String} -> ReferencedObjectType
+  ArrayObjectType ::
+    { arrayObjectTypeType :: ReferencedObjectType,
+      arryObjecttTypeNumber :: Word32
+    } ->
+    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 :: Integer,
+      -- | 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
+
+-- | 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)