Further implement C backend.

There is a problem where I'm mixing up bits and bytes. I think I'll try
to resolve that using more type-level constraints.

1 files changed, 62 insertions, 11 deletions

diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
index 2e6421e..645fa85 100644
--- a/src/Language/Fiddle/Compiler/Backend/C.hs
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -6,10 +6,7 @@
 module Language.Fiddle.Compiler.Backend.C (cBackend) where
 
 import Control.Arrow (Arrow (second))
-import Control.Exception (TypeError (TypeError))
-import Control.Monad.Identity (Identity (Identity))
 import Control.Monad.RWS
-import Control.Monad.Writer
 import Data.Char (isSpace)
 import Data.Data (Typeable, cast)
 import Data.Foldable (forM_, toList)
@@ -33,13 +30,16 @@ data CBackendFlags = CBackendFlags
     cHeaderOut :: FilePath
   }
 
-data FilePosition = FilePosition Int
+newtype FilePosition = FilePosition Int
   deriving (Eq, Ord)
 
+headerPos :: FilePosition
 headerPos = FilePosition 0
 
+middlePos :: FilePosition
 middlePos = FilePosition 50
 
+footerPos :: FilePosition
 footerPos = FilePosition 100
 
 tellLn :: (MonadWriter Text m) => Text -> m ()
@@ -212,7 +212,54 @@ pad :: (IsString t, MonadWriter t m) => m a -> m a
 pad f = tell "\n" *> f <* tell "\n"
 
 structBody :: ObjTypeBody Checked I A -> FormattedWriter ()
-structBody _ = return ()
+structBody (ObjTypeBody _ decls _) = do
+  forM_ decls $ \(Directed _ decl _) ->
+    case decl of
+      RegisterDecl
+        { regSpan = Present (FieldSpan _ sz),
+          regIdent = Guaranteed (identToString -> i),
+          regAnnot = ann
+        } -> do
+          emitDocComments ann
+          tell (sizeToField i sz)
+          tell ";\n"
+      ReservedDecl
+        { regSpan = Present (FieldSpan _ sz),
+          reservedIdent = Present i,
+          reservedAnnot = ann
+        } -> do
+          emitDocComments ann
+          tell (sizeToField i sz)
+          tell ";\n"
+      TypeSubStructure
+        { subStructureBody = Identity bod,
+          subStructureName = mname
+        } -> do
+          tell $ case objBodyType bod of
+            Union {} -> "union "
+            Struct {} -> "struct "
+
+          body $ structBody bod
+
+          forM_ mname $ \name ->
+            tell (Text.pack $ identToString name)
+
+          tell ";\n"
+  where
+    sizeToField (Text.pack -> f) = \case
+      1 -> "volatile uint8_t " <> f
+      2 -> "volatile uint16_t " <> f
+      4 -> "volatile uint32_t " <> f
+      8 -> "volatile uint64_t " <> f
+      n -> "volatile uint8_t " <> f <> "[" <> Text.pack (show n) <> "]"
+
+union :: Text -> FormattedWriter () -> FormattedWriter ()
+union identifier fn = do
+  tell "#pragma pack(push, 1)\n"
+  tell $ "union " <> identifier <> " "
+  body fn
+  tell ";\n"
+  tell "#pragma pack(pop)\n"
 
 struct :: Text -> FormattedWriter () -> FormattedWriter ()
 struct identifier fn = do
@@ -228,8 +275,8 @@ body f = tell "{\n" *> indented f <* (ensureNL >> tell "}")
 identifierFor :: (ExportableDecl d) => d -> Text
 identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata
 
-emitDocComments :: (MonadWriter Text m) => A -> m ()
-emitDocComments (Commented comments _) =
+emitDocComments :: A -> FormattedWriter ()
+emitDocComments (Commented comments _) = do
   mapM_ (\t -> tellLn $ "// " <> t) $
     mapMaybe
       ( \case
@@ -237,6 +284,7 @@ emitDocComments (Commented comments _) =
           _ -> Nothing
       )
       comments
+  ensureNL
   where
     trimDocComment =
       Text.dropWhileEnd isSpace
@@ -244,28 +292,31 @@ emitDocComments (Commented comments _) =
         . dropIf (== '*')
         . Text.dropWhile isSpace
 
-    dropIf fn t | Text.null t = mempty
+    dropIf _ t | Text.null t = mempty
     dropIf fn t =
       if fn (Text.head t)
         then Text.tail t
         else t
 
 transpileWalk :: Either ImplementationInHeader FilePath -> FilePath -> (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ()))
-transpileWalk sourceFile headerFile t _ = case () of
+transpileWalk _ headerFile t _ = case () of
   ()
     | Just
         ( ObjTypeDecl
             { objTypeQualificationMetadata = Identity metadata,
-              objTypeIdent = (identToString -> identifier),
               objTypeBody = Identity objTypeBody,
               objTypeAnnot = a
             }
           ) <-
         castTS t -> do
+        let structureType = case objBodyType objTypeBody of
+              Union {} -> union
+              Struct {} -> struct
+
         withFileAt headerFile middlePos $ do
           pad $ do
             emitDocComments a
-            struct (identifierFor (unwrap metadata)) $ do
+            structureType (identifierFor (unwrap metadata)) $ do
               structBody objTypeBody
         return Stop
   _ -> return (Continue ())