Another monolithic change. Not good git ettiquite.

Import statements are fully implemented including compiling to an
interface file for faster compilations.

2 files changed, 77 insertions, 0 deletions

diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index eea4c6f..ac6f7d1 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -3,6 +3,8 @@
 module Language.Fiddle.Internal.Scopes where
 
 import Control.Monad (forM)
+import Data.Aeson
+import Data.Aeson.Key
 import Data.List (inits, intercalate)
 import Data.List.NonEmpty (NonEmpty (..), prependList)
 import Data.Map (Map)
@@ -64,6 +66,9 @@ upsertScope (s :| (a : as)) v (Scope ss sv) =
       (replaced, subscope') = upsertScope (a :| as) v subscope
    in (replaced, Scope (Map.insert s subscope' ss) sv)
 
+insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
+insertScope p s = snd . upsertScope p s
+
 -- insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
 -- insertScope a b = snd . upsertScope a b
 
@@ -108,3 +113,17 @@ lookupScopeWithPath (ScopePath current others) key scope =
         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 subScopes scopeValues) =
+    object
+      [ fromString "subScopes" .= toJSON subScopes,
+        fromString "scopeValues" .= toJSON scopeValues
+      ]
+
+instance (FromJSONKey k, FromJSON v, Ord k) => FromJSON (Scope k v) where
+  parseJSON (Object v) =
+    Scope
+      <$> v .: fromString "subScopes"
+      <*> v .: fromString "scopeValues"
+  parseJSON _ = fail "Expected an object for Scope"
diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs
index 1f12c4c..b18b98b 100644
--- a/src/Language/Fiddle/Internal/UnitInterface.hs
+++ b/src/Language/Fiddle/Internal/UnitInterface.hs
@@ -1,5 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Language.Fiddle.Internal.UnitInterface where
 
+import Data.Aeson
 import Data.Text
 import Data.Word
 import Language.Fiddle.Internal.Scopes (Scope)
@@ -24,6 +27,13 @@ data UnitInterface where
     UnitInterface
   deriving (Eq, Ord, Show)
 
+instance Semigroup UnitInterface where
+  (<>) (UnitInterface s d) (UnitInterface s1 d1) =
+    UnitInterface (s <> s1) (d <> d1)
+
+instance Monoid UnitInterface where
+  mempty = UnitInterface mempty mempty
+
 data ExportedValue where
   ExportedBitsType ::
     {exportBitsTypeSize :: Word32} ->
@@ -32,3 +42,51 @@ data ExportedValue where
     {exportObjTypeSize :: Word32} ->
     ExportedValue
   deriving (Show, Eq, Ord)
+
+instance (ToJSON a) => ToJSON (Annotated a) where
+  toJSON (Annotated span doc internal) =
+    object
+      [ "sourceSpan" .= span,
+        "docComment" .= doc,
+        "internal" .= internal
+      ]
+
+instance (FromJSON a) => FromJSON (Annotated a) where
+  parseJSON = withObject "Annotated" $ \v ->
+    Annotated
+      <$> v .: "sourceSpan"
+      <*> v .: "docComment"
+      <*> v .: "internal"
+
+instance ToJSON UnitInterface where
+  toJSON (UnitInterface rootScope dependencies) =
+    object
+      [ "rootScope" .= rootScope,
+        "dependencies" .= dependencies
+      ]
+
+instance FromJSON UnitInterface where
+  parseJSON = withObject "UnitInterface" $ \v ->
+    UnitInterface
+      <$> v .: "rootScope"
+      <*> v .: "dependencies"
+
+instance ToJSON ExportedValue where
+  toJSON (ExportedBitsType size) =
+    object
+      [ "type" .= String "ExportedBitsType",
+        "size" .= size
+      ]
+  toJSON (ExportedObjType size) =
+    object
+      [ "type" .= String "ExportedObjType",
+        "size" .= size
+      ]
+
+instance FromJSON ExportedValue where
+  parseJSON = withObject "ExportedValue" $ \v -> do
+    typ <- v .: "type"
+    case typ of
+      String "ExportedBitsType" -> ExportedBitsType <$> v .: "size"
+      String "ExportedObjType" -> ExportedObjType <$> v .: "size"
+      _ -> fail "Unknown ExportedValue type"