Much better handling for the generic syntax tree.

It now converts normal data into JSON rather than using "show".

3 files changed, 86 insertions, 34 deletions

diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
index 410f3e2..abcf214 100644
--- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
+++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs
@@ -61,7 +61,13 @@ deriving instance AdvanceStage S AnonymousBitsType
 
 deriving instance AdvanceStage S ImportStatement
 
-deriving instance AdvanceStage S BitType
+instance AdvanceStage S BitType where
+  customAdvanceStage t _ = do
+    case t of
+      (EnumBitType sz body _) -> do
+        checkEnumConsistency sz body
+      _ -> return ()
+    return Nothing
 
 deriving instance AdvanceStage S EnumBody
 
@@ -282,3 +288,47 @@ checkBitsSizeMod8 a w = do
     (printf "Register size %d is not a multiple of 8. Please add padding to this register." w)
     a
   return ((w `div` 8) + 1)
+
+-- getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
+--   declaredSize <- fromIntegral <$> exprToSize expr
+--
+--   -- If the declared size is less than or equal to 4, we'll enforce that the
+--   -- enum is packed. This is to make sure the user has covered all bases.
+--   when (declaredSize <= 4) $ do
+--     imap <-
+--       foldlM
+--         ( \imap (undirected -> enumConst) -> do
+--             number <- case enumConst of
+--               EnumConstantDecl _ expr _ -> exprToSize expr
+--               EnumConstantReserved expr _ -> exprToSize expr
+--
+--             when (number >= 2 ^ declaredSize) $
+--               tell
+--                 [ Diagnostic
+--                     Error
+--                     ( printf
+--                         "Enum constant too large. Max allowed %d\n"
+--                         ((2 :: Int) ^ declaredSize)
+--                     )
+--                     (unCommented (annot enumConst))
+--                 ]
+--
+--             return $ IntMap.insert (fromIntegral number) True imap
+--         )
+--         IntMap.empty
+--         constants
+--     let missing =
+--           filter (not . (`IntMap.member` imap)) [0 .. 2 ^ declaredSize - 1]
+--     unless (null missing) $
+--       tell
+--         [ Diagnostic
+--             Warning
+--             ( printf
+--                 "Missing enum constants %s. Small enums should be fully \
+--                 \ populated. Use 'reserved' if needed."
+--                 (intercalate ", " (map show missing))
+--             )
+--             (unCommented ann)
+--         ]
+--
+--   return declaredSize
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs
index 165949a..e951623 100644
--- a/src/Language/Fiddle/GenericTree.hs
+++ b/src/Language/Fiddle/GenericTree.hs
@@ -27,15 +27,15 @@ import Language.Fiddle.Types
 type Context stage =
   ( Show (NumberType stage),
     Typeable stage,
-    ToGenericSyntaxTreeValue (NumberType stage),
-    Show (ImportInterface stage),
-    Show (FiddleUnitInterface stage),
-    Show (QualificationMetadata stage ()),
-    Show (QualificationMetadata stage ExportedPackageDecl),
-    Show (QualificationMetadata stage ExportedLocationDecl),
-    Show (QualificationMetadata stage ExportedBitsDecl),
-    Show (QualificationMetadata stage ExportedTypeDecl),
-    Show (QualificationMetadata stage ExportedObjectDecl)
+    ToJSON (NumberType stage),
+    ToJSON (ImportInterface stage),
+    ToJSON (FiddleUnitInterface stage),
+    ToJSON (QualificationMetadata stage ()),
+    ToJSON (QualificationMetadata stage ExportedPackageDecl),
+    ToJSON (QualificationMetadata stage ExportedLocationDecl),
+    ToJSON (QualificationMetadata stage ExportedBitsDecl),
+    ToJSON (QualificationMetadata stage ExportedTypeDecl),
+    ToJSON (QualificationMetadata stage ExportedObjectDecl)
   )
 
 class FunctorShow f where
@@ -62,7 +62,7 @@ data GenericSyntaxTree f a where
     GenericSyntaxTree f a
   SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a
   SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a
-  SyntaxTreeValue :: String -> GenericSyntaxTree f a
+  SyntaxTreeValue :: Value -> GenericSyntaxTree f a
 
 alterGenericSyntaxTree ::
   (Functor f) =>
@@ -103,7 +103,7 @@ instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where
       Array $ Data.Vector.fromList $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
       toJSON (SyntaxTreeList $ Data.Foldable.toList fdef)
-    (SyntaxTreeValue s) -> String (Data.Text.pack s)
+    (SyntaxTreeValue s) -> toJSON s
 
   toEncoding = \case
     (SyntaxTreeObject typ membs (Just a) t) ->
@@ -114,26 +114,23 @@ instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where
       foldable $ map toJSON l
     (SyntaxTreeDeferred fdef) ->
       toEncoding (SyntaxTreeList $ Data.Foldable.toList fdef)
-    (SyntaxTreeValue s) -> text (Data.Text.pack s)
+    (SyntaxTreeValue v) -> toEncoding v
 
-class ToGenericSyntaxTreeValue v where
-  toGenericSyntaxTreeValue :: forall f a. v -> Maybe (GenericSyntaxTree f a)
+class ToGenericSyntaxTreeValue f v where
+  toGenericSyntaxTreeValue :: forall a. v -> Maybe (GenericSyntaxTree f a)
   default toGenericSyntaxTreeValue ::
-    forall f a. (Show v) => v -> Maybe (GenericSyntaxTree f a)
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+    forall a. (ToJSON v) => v -> Maybe (GenericSyntaxTree f a)
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON
 
-instance ToGenericSyntaxTreeValue (f a) where
-  toGenericSyntaxTreeValue = const Nothing
+instance ToGenericSyntaxTreeValue f Data.Text.Text where
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . String
 
-instance ToGenericSyntaxTreeValue Data.Text.Text where
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . Data.Text.unpack
-
-instance (Show s) => ToGenericSyntaxTreeValue s where
-  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show
+instance (ToJSON s) => ToGenericSyntaxTreeValue f s where
+  toGenericSyntaxTreeValue = Just . SyntaxTreeValue . toJSON
 
 -- Witnesses exist just for type level meta programming, don't return anything
 -- if we don't need it.
-instance ToGenericSyntaxTreeValue (Witness b) where
+instance ToGenericSyntaxTreeValue f (Witness b) where
   toGenericSyntaxTreeValue _ = Nothing
 
 type GenericContext t f a = (Traversable f, ToGenericSyntaxTree t, Typeable t, Typeable f, Typeable a)
@@ -152,7 +149,7 @@ class GToGenericSyntaxTree r f a where
 class GToMemberList r f a where
   gToMemberList :: Int -> r x -> [GenericSyntaxTree f a]
 
-instance (ToGenericSyntaxTreeValue v) => GToMemberList (Rec0 v) f a where
+instance (ToGenericSyntaxTreeValue f v) => GToMemberList (Rec0 v) f a where
   gToMemberList _ = toList . toGenericSyntaxTreeValue . unK1
 
 instance
@@ -161,10 +158,10 @@ instance
   where
   gToGenericSyntaxTree _ k1 = SyntaxTreeDeferred (toGenericSyntaxTree <$> unK1 k1)
 
-instance
-  GToGenericSyntaxTree (Rec0 (f x)) f a
-  where
-  gToGenericSyntaxTree _ k1 = SyntaxTreeList []
+-- instance
+--   GToGenericSyntaxTree (Rec0 (f x)) f a
+--   where
+--   gToGenericSyntaxTree _ k1 = SyntaxTreeList []
 
 instance
   (GenericContext r f a, Traversable f1) =>
@@ -254,7 +251,12 @@ deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeBody stage))
 
 deriving instance (Context stage) => (ToGenericSyntaxTree (ObjTypeDecl stage))
 
-deriving instance (ToGenericSyntaxTreeValue ModifierKeyword)
+instance (ToGenericSyntaxTreeValue f ModifierKeyword) where
+  toGenericSyntaxTreeValue kw = Just $ SyntaxTreeValue $ String (Data.Text.pack $ show kw)
+
+instance (Functor f, ToJSON a) => (ToGenericSyntaxTreeValue f (f a)) where
+  toGenericSyntaxTreeValue mv =
+     Just $ SyntaxTreeDeferred $ SyntaxTreeValue . toJSON <$> mv
 
 deriving instance (ToGenericSyntaxTree Modifier)
 
diff --git a/src/Main.hs b/src/Main.hs
index 4da2295..2e4ee7a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,7 +2,7 @@ module Main where
 
 import Control.Monad (forM_)
 import Control.Monad.Identity (Identity)
-import Data.Aeson (Value (..), encode)
+import Data.Aeson (ToJSON (..), Value (..), encode)
 import qualified Data.ByteString.Lazy.Char8 as BL
 import qualified Data.Text as Text
 import qualified Data.Text.IO as TextIO
@@ -138,7 +138,7 @@ processCompilationResult ma =
           encode $
             alterGenericSyntaxTree cleanupIdentifiers $
               toGenericSyntaxTree $
-                fmap (Just . String . Text.pack . show) ast
+                fmap (Just . toJSON) ast
       return ExitSuccess
     Nothing -> do
       putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
@@ -155,7 +155,7 @@ handleParsingFailure diags = do
 cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a)
 cleanupIdentifiers (SyntaxTreeObject _ _ _ tr)
   | Just (Identifier n _) <- castT tr =
-      Just $ SyntaxTreeValue (Text.unpack n)
+      Just $ SyntaxTreeValue (String n)
   where
     castT :: (Typeable t, Typeable f, Typeable a, Typeable t') => t f a -> Maybe (t' f a)
     castT = cast