path: root/src/Language/Fiddle/Compiler/Backend/C.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}

module Language.Fiddle.Compiler.Backend.C (cBackend) where

import Control.Arrow
import Control.Monad (forM, unless)
import Control.Monad.RWS
import Control.Monad.Trans.Writer hiding (tell)
import qualified Data.Bits
import Data.Char (isSpace)
import Data.Data (Typeable, cast)
import Data.Foldable (forM_)
import Data.Kind (Type)
import qualified Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Fiddle.Ast
import Language.Fiddle.Compiler.Backend
import Language.Fiddle.Compiler.Backend.Internal
import Language.Fiddle.Compiler.Backend.Internal.FormattedWriter
import qualified Language.Fiddle.Compiler.Backend.Internal.FragTree as FragTree
import Language.Fiddle.Compiler.Backend.Internal.Writer
import Language.Fiddle.Internal.UnitInterface
import Language.Fiddle.Internal.UnitNumbers
import Language.Fiddle.Types
import Numeric (showHex)
import Options.Applicative
import Text.Printf (printf)

newtype CBackendFlags = CBackendFlags
  { cHeaderOut :: FilePath
  }

data SIntfF
  = SIntfF
  { _sIntfFValue :: Text,
    _sIntfFComemnts :: FormattedWriter ()
  }

newtype SIntf
  = SIntf
      ( Map String (Either SIntfF SIntf)
      )

instance Monoid SIntf where
  mempty = SIntf mempty

instance Semigroup SIntf where
  (<>) (SIntf m1) (SIntf m2) =
    SIntf $
      Map.unionWith
        ( \a b -> case (a, b) of
            (Right a, Right b) -> Right (a <> b)
            (Left _, Left b) -> Left b
            (Right a, Left _) -> Right a
            (_, Right a) -> Right a
        )
        m1
        m2

class SIntfSingleton a where
  sIntfSingleton :: String -> a -> SIntf

instance SIntfSingleton SIntfF where
  sIntfSingleton s = SIntf . Map.singleton s . Left

instance SIntfSingleton SIntf where
  sIntfSingleton s = SIntf . Map.singleton s . Right

type StructName = Text

sIntfToC :: SIntf -> M ()
sIntfToC (SIntf m) = do
  text "struct "
  body $
    forM_ (Map.toList m) $ \(k, v) -> do
      case v of
        Left (SIntfF txt emitCom) -> do
          textM emitCom
          text $ "typeof(" <> txt <> ")* " <> Text.pack k <> ";\n"
        Right sub -> do
          sIntfToC sub
          text " "
          text $ Text.pack k
          text ";\n"

sIntfToRVal :: SIntf -> M ()
sIntfToRVal (SIntf m) = do
  body $ do
    sequence_ $
      Data.List.intersperse (text ",\n") $
        map
          ( \(k, v) -> do
              case v of
                Left (SIntfF txt _) ->
                  text $ "." <> Text.pack k <> " = " <> txt
                Right sub -> do
                  text $ "." <> Text.pack k <> " = "
                  sIntfToRVal sub
          )
          (Map.toList m)
    text "\n"

-- | Header fragment. The top. Starts which include guards and has include
-- statements.
hF :: FileFragment
hF = ("HEADER", FragTree.above FragTree.center)

-- | Structures fragment. The text fragment where structures are defined.
sF :: FileFragment
sF = ("HEADER", FragTree.below (snd hF))

-- | Implementation fragment. This is where function implementations go.
iF :: FileFragment
iF = ("HEADER", FragTree.above (snd fF))

-- | Assert fragment. This is where static asserts go.
aF :: FileFragment
aF = ("HEADER", FragTree.below (snd sF))

-- | Footer fragment. This is wehre the file include endif goes.
fF :: FileFragment
fF = ("HEADER", FragTree.below FragTree.center)

-- | Interface fragment. This is wehre interfaces are stored.
intfF :: FileFragment
intfF = ("HEADER", FragTree.above (snd fF))

type A = Commented SourceSpan

type I = Identity

type M a = FilesM () FormattedWriter CFileState a

newtype CFileState = CFileState
  { includedFiles :: Set String
  }

requireInclude :: String -> M ()
requireInclude file = do
  b <- gets (Set.member file . includedFiles)
  unless b $ do
    checkout hF $
      text $
        Text.pack $
          printf "#include <%s>\n" file
    modify $ \s -> s {includedFiles = Set.insert file (includedFiles s)}

cBackend :: Backend
cBackend =
  Backend
    { backendName = "C",
      backendOptionsParser =
        CBackendFlags
          <$> strOption
            ( long "c-header-out"
                <> short 'h'
                <> help "Output file for the C header file."
                <> metavar "HEADER_OUT"
            ),
      backendIOMakeState = const $ return (),
      backendTranspile = transpile
    }

transpile ::
  CBackendFlags ->
  () ->
  FiddleUnit Checked Identity (Commented SourceSpan) ->
  TranspileResult
transpile
  CBackendFlags
    { cHeaderOut = headerFile
    }
  ()
  fiddleUnit = toTranspileResult $ fst $ runFilesM execFormattedWriter () (CFileState mempty) hF run
    where
      toTranspileResult :: Map FilePath Text -> TranspileResult
      toTranspileResult mp =
        TranspileResult $
          Map.mapKeys
            ( \case
                "HEADER" -> headerFile
                k -> k
            )
            mp

      run = do
        checkout hF $
          textM $ do
            tell $ "#ifndef " <> headerGuard <> "\n"
            tell $ "#define " <> headerGuard <> "\n\n"
            tell "#include <stdint.h>\n"

        -- Pad out the implementation
        checkout iF $ text "\n"

        walk (transpileWalk headerFile) fiddleUnit ()

        checkout hF $
          textM $ do
            tell "\n_Static_assert(1); // https://github.com/clangd/clangd/issues/1167\n"

        checkout fF $
          text headerFinal

      headerFinal = "\n#endif /* " <> headerGuard <> " */\n"

      headerGuard =
        Text.toUpper $
          Text.replace "." "_" $
            Text.replace "/" "_" $
              Text.pack headerFile

qualifiedPathToIdentifier :: QualifiedPath String -> Text
qualifiedPathToIdentifier = Text.pack . qualifiedPathToString "__" "_"

pad :: M () -> M ()
pad f = text "\n" *> f <* text "\n"

writeStaticAssert :: Text -> String -> N Bytes -> M ()
writeStaticAssert structName regname off = do
  requireInclude "stddef.h"
  text $
    Text.pack $
      printf
        "\n_Static_assert(offsetof(struct %s, %s) == 0x%x, \"Offset wrong\");\n"
        structName
        regname
        off

sizeToType :: N Bytes -> Maybe String
sizeToType = \case
  1 -> Just "uint8_t"
  2 -> Just "uint16_t"
  4 -> Just "uint32_t"
  8 -> Just "uint64_t"
  _ -> Nothing

selectByModifier :: Modifier f an -> (a, a) -> [a]
selectByModifier mod (getter, setter) =
  case mod of
    (ModifierKeyword Rw _) -> [getter, setter]
    (ModifierKeyword Ro _) -> [getter]
    (ModifierKeyword Wo _) -> [setter]
    (ModifierKeyword Pr _) -> []

writeRegGet :: StructName -> QRegMetadata True -> A -> M SIntf
writeRegGet
  structType
  ( QRegMetadata
      { regSpan =
          Present
            FieldSpan
              { size = size
              },
        regFullPath = fullPath
      }
    )
  docComms = do
    let fnName = qualifiedPathToIdentifier fullPath <> "__get"
        returnType = sizeToType size
        fieldName = basenamePart fullPath

    case returnType of
      Just rt -> do
        textM $ do
          tell $
            Text.pack $
              printf "static inline %s %s(const struct %s* o) {\n" rt fnName structType
          tell $ Text.pack $ printf "  return o->%s;\n" fieldName
          tell "}\n\n"
      Nothing ->
        -- Return type is not defined, fallback to byte-by-byte copy.
        textM $ do
          tell $
            Text.pack $
              printf
                "static inline void %s(%s* o, uint8_t out[%d]) {\n"
                fnName
                structType
                size
          forM_ [0 .. size - 1] $ \i ->
            tell $ Text.pack $ printf "  out[%d] = o->%s[%d];\n" i fieldName i
          tell "}\n\n"

    return $ sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms))

writeRegSet :: StructName -> QRegMetadata True -> A -> M SIntf
writeRegSet
  structType
  ( QRegMetadata
      { regSpan =
          Present
            FieldSpan
              { size = size
              },
        regFullPath = fullPath
      }
    )
  docComs = do
    let fnName = qualifiedPathToIdentifier fullPath <> "__set"
        setType = sizeToType size
        fieldName = basenamePart fullPath

    case setType of
      Just rt -> do
        textM $ do
          tell $
            Text.pack $
              printf "static inline void %s(struct %s* o, %s v) {\n" fnName structType rt
          tell $ Text.pack $ printf "  o->%s = v;\n" fieldName
          tell "}\n\n"
      Nothing ->
        -- Return type is not defined, fallback to byte-by-byte copy.
        textM $ do
          tell $
            Text.pack $
              printf
                "static inline void %s(struct %s* o, const uint8_t in[%d]) {\n"
                fnName
                structType
                size
          forM_ [0 .. size - 1] $ \i ->
            tell $ Text.pack $ printf "  o->%s[%d] = in[%d];\n" fieldName i i
          tell "}\n\n"

    return $ sIntfSingleton "set" (SIntfF fnName (emitDocComments docComs))

pattern DefinedBitsP ::
  Modifier f a ->
  String ->
  QualifiedPath String ->
  N Bits ->
  RegisterBitsTypeRef Checked f A ->
  A ->
  RegisterBitsDecl Checked f A
pattern DefinedBitsP modifier bitsName bitsFullPath offset typeRef annot <-
  ( DefinedBits
      { qBitsMetadata =
          Present
            QBitsMetadata
              { bitsSpan =
                  Present
                    FieldSpan
                      { offset = offset
                      },
                bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath))
              },
        definedBitsTypeRef = typeRef,
        definedBitsModifier = (Guaranteed modifier),
        definedBitsAnnot = annot
      }
    )

pattern BitsSubstructureP ::
  Modifier f a ->
  String ->
  QualifiedPath String ->
  N Bits ->
  N Bits ->
  RegisterBody Checked f A ->
  A ->
  RegisterBitsDecl Checked f A
pattern BitsSubstructureP modifier bitsName bitsFullPath offset size subRegisterBody annot <-
  BitsSubStructure
    { qBitsMetadata =
        Present
          QBitsMetadata
            { bitsSpan =
                Present
                  FieldSpan
                    { offset = offset,
                      size = size
                    },
              bitsFullPath = (basenamePart &&& id -> (bitsName, bitsFullPath))
            },
      bitsModifier = (Guaranteed modifier),
      bitsSubRegBody = subRegisterBody,
      bitsSubAnnot = annot
    }

writeBitsGet ::
  StructName ->
  QRegMetadata True ->
  QualifiedPath String ->
  N Bits ->
  RegisterBitsTypeRef 'Checked I A ->
  A ->
  M SIntf
writeBitsGet structName regmeta fullPath offset typeRef docComms = do
  let fnName = qualifiedPathToIdentifier fullPath <> "__get"
      bitsName = basenamePart fullPath
      retType = typeRefBaseType typeRef
      regName = basenamePart (regFullPath regmeta)
      regCType = getRegCType regmeta

  text $ "inline static " <> retType <> " "
  text fnName
  text "(\n    struct "
  text structName
  text " *o"

  let shiftArguments =
        zipWith
          (\a b -> if b == 1 then a else a <> " * " <> s b)
          (tail setterArgumentNames)
          (snd $ offsetCoefficients typeRef)

  unless (null shiftArguments) $
    text ", "

  text $
    Text.intercalate ", " $
      zipWith (\f _ -> "int " <> f) (tail setterArgumentNames) shiftArguments

  text ") {\n"

  withIndent $ do
    if null shiftArguments
      then do
        text $ regCType <> " shift_ = " <> s offset
      else do
        text $ regCType <> " shift_ = "
        text $ Text.intercalate " + " (shiftArguments ++ [s offset | offset /= 0])
    text ";\n"

    text $ regCType <> " mask_ = "
    text $ typeRefToGetMask typeRef
    text " << shift_;\n"

    text $ retType <> " ret = (" <> retType <> ")((o->" <> Text.pack regName <> " & mask_) >> shift_);\n"
    text "return ret;\n"
  text "}\n\n"
  return $
    sIntfSingleton bitsName $
      sIntfSingleton "get" (SIntfF fnName (emitDocComments docComms))
  where
    offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int])
    offsetCoefficients
      RegisterBitsJustBits
        { justBitsExpr = fromIntegral . trueValue -> sz
        } = (sz, [])
    offsetCoefficients
      RegisterBitsReference
        { bitsRefQualificationMetadata =
            Identity
              ( Present
                  ( ExportedBitsDecl
                      { exportedBitsDeclSizeBits = sz
                      }
                    )
                )
        } = (fromIntegral sz, [])
    offsetCoefficients (RegisterBitsArray tr n _) =
      let (recsz, rest) = offsetCoefficients tr
       in ( recsz * fromIntegral (trueValue n),
            rest ++ [recsz]
          )

    s :: (Show a) => a -> Text
    s = Text.pack . show

    typeRefToGetMask :: RegisterBitsTypeRef Checked I a -> Text
    typeRefToGetMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToGetMask ref
    typeRefToGetMask
      RegisterBitsJustBits
        { justBitsExpr = fromIntegral . trueValue -> sz
        } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "")
    typeRefToGetMask
      RegisterBitsReference
        { bitsRefQualificationMetadata =
            Identity
              ( Present
                  ( ExportedBitsDecl
                      { exportedBitsDeclSizeBits = sz
                      }
                    )
                )
        } =
        let num :: Int
            num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1
         in "0x" <> Text.pack (showHex num "")

getRegCType :: QRegMetadata True -> Text
getRegCType meta =
  Text.pack $
    fromMaybe "unsigned" $
      sizeToType (size (unwrap (regSpan meta)))

writeBitsSet ::
  Bool ->
  StructName ->
  QRegMetadata True ->
  QualifiedPath String ->
  N Bits ->
  RegisterBitsTypeRef 'Checked I A ->
  A ->
  M SIntf
writeBitsSet writeOnly structName regmeta fullPath offset typeRef docComms = do
  let fnName = qualifiedPathToIdentifier fullPath <> "__set"
      bitsName = basenamePart fullPath
      regName = basenamePart (regFullPath regmeta)
      regCType = getRegCType regmeta

  text "inline static void "
  text fnName
  text "(\n    struct "
  text structName
  text " *o,\n    "
  typeRefToArgs typeRef
  text ") {\n"

  let shiftArguments =
        zipWith
          (\a b -> if b == 1 then a else a <> " * " <> s b)
          (tail setterArgumentNames)
          (snd $ offsetCoefficients typeRef)
          ++ [s offset | offset /= 0]

  withIndent $ do
    let mask = typeRefToMask typeRef

    text $ regCType <> " mask_ = " <> mask <> ";\n"
    unless (null shiftArguments) $ do
      text $
        regCType <> " shift_ = " <> Text.intercalate " + " shiftArguments <> ";\n"
      text "mask_ <<= shift_;\n"

    text "int to_set_ = value"

    unless (null shiftArguments) $ do
      text " << shift_"
    text ";\n"
    text "to_set_ &= mask_;\n"

    unless writeOnly $ do
      text $ regCType <> " current_ = o->" <> Text.pack regName <> ";\n"
      text "to_set_ = current_ ^ (current_ & mask_) ^ to_set_;\n"

    text $ "o->" <> Text.pack regName <> " = to_set_;\n"
  text "}\n\n"
  return $
    sIntfSingleton bitsName $
      sIntfSingleton "set" (SIntfF fnName (emitDocComments docComms))
  where
    offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int])
    offsetCoefficients
      RegisterBitsJustBits
        { justBitsExpr = fromIntegral . trueValue -> sz
        } = (sz, [])
    offsetCoefficients
      RegisterBitsReference
        { bitsRefQualificationMetadata =
            Identity
              ( Present
                  ( ExportedBitsDecl
                      { exportedBitsDeclSizeBits = sz
                      }
                    )
                )
        } = (fromIntegral sz, [])
    offsetCoefficients (RegisterBitsArray tr n _) =
      let (recsz, rest) = offsetCoefficients tr
       in ( recsz * fromIntegral (trueValue n),
            rest ++ [recsz]
          )

    s :: (Show a) => a -> Text
    s = Text.pack . show

    typeRefToMask :: RegisterBitsTypeRef Checked I a -> Text
    typeRefToMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToMask ref
    typeRefToMask
      RegisterBitsJustBits
        { justBitsExpr = fromIntegral . trueValue -> sz
        } = "0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "")
    typeRefToMask
      RegisterBitsReference
        { bitsRefQualificationMetadata =
            Identity
              ( Present
                  ( ExportedBitsDecl
                      { exportedBitsDeclSizeBits = sz
                      }
                    )
                )
        } =
        let num :: Int
            num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1
         in "0x" <> Text.pack (showHex num "")

typeRefBaseType :: RegisterBitsTypeRef 'Checked I A -> Text
typeRefBaseType = typeRefBaseType'
  where
    typeRefBaseType'
      ( RegisterBitsJustBits
          { justBitsExpr = ConstExpression (LeftV v) _
          }
        ) = typeForBits v
    typeRefBaseType'
      ( RegisterBitsReference
          { bitsRefQualificationMetadata = (Identity (Present md))
          }
        ) =
        "enum "
          <> qualifiedPathToIdentifier
            (metadataFullyQualifiedPath $ getMetadata md)
    typeRefBaseType' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) =
      typeRefBaseType' tr

    typeForBits = \case
      64 -> "uint64_t"
      32 -> "uint32_t"
      16 -> "uint16_t"
      8 -> "uint8_t"
      _ -> "unsigned"

typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M ()
typeRefToArgs reg =
  text
    $ Text.intercalate ",\n    "
    $ zipWith
      (\n t -> t <> " " <> n)
      setterArgumentNames
    $ typeRefToArgs' reg
  where
    typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) =
      typeRefToArgs' tr ++ ["int"]
    typeRefToArgs' x = [typeRefBaseType x]

-- | Decomposes a type ref into a type name (String) and a list of dimensions
-- (in the case of being an array)
-- decomposeBitsTypeRef :: RegisterBitsTypeRef Checked I A -> (String, [N Unitless])
-- decomposeBitsTypeRef (RegisterBitsJustBits )
writeRegisterBody ::
  StructName -> QRegMetadata True -> RegisterBody Checked I A -> M SIntf
writeRegisterBody structName regmeta t = execWriterT $ walk (\t' () -> registerWalk t') t ()
  where
    registerWalk ::
      forall t.
      (Walk t, Typeable t) =>
      t I A ->
      WriterT SIntf (FilesM () FormattedWriter CFileState) (WalkContinuation ())
    registerWalk t = case () of
      ()
        | (Just (DefinedBitsP modifier _ fullPath offset typeRef annot)) <- castTS t ->
            let isWo = case modifier of
                  ModifierKeyword Wo _ -> True
                  _ -> False
             in do
                  lift $ textM $ emitDocComments annot
                  sequence_ $
                    selectByModifier
                      modifier
                      ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
                        tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
                      )
                  return Stop
      () | (Just (BitsSubstructureP modifier bitsName fullPath offset size subBody annot)) <- castTS t -> do
        sIntf <- lift (writeRegisterBody structName regmeta subBody)
        let isWo = case modifier of
              ModifierKeyword Wo _ -> True
              _ -> False
        if null bitsName
          then tell sIntf
          else do
            -- Make a typeref here which is defined as "just bitse"
            let typeRef =
                  RegisterBitsJustBits
                    (ConstExpression (LeftV size) annot)
                    annot

            tell $ sIntfSingleton bitsName sIntf
            lift $ textM $ emitDocComments annot
            sequence_ $
              selectByModifier
                modifier
                ( tell =<< lift (writeBitsGet structName regmeta fullPath offset typeRef annot),
                  tell =<< lift (writeBitsSet isWo structName regmeta fullPath offset typeRef annot)
                )

        return Stop
      -- text $
      --   Text.pack $
      --     printf
      --       "// Emit bits %s (%s) at %d\n"
      --       bitsName
      --       (qualifiedPathToIdentifier fullPath)
      --       offset
      _ -> return $ Continue ()

    castTS ::
      forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type).
      ( Typeable t',
        Typeable t,
        Typeable f,
        Typeable a
      ) =>
      t' f a ->
      Maybe (t Checked f a)
    castTS = cast

writeImplementation ::
  StructName ->
  QRegMetadata True ->
  Modifier f a ->
  Maybe (RegisterBody Checked I A) ->
  A ->
  M SIntf

-- | Register is just padding, don't emit anything
writeImplementation _ (regIsPadding -> True) _ _ _ = return mempty
writeImplementation structName qMeta mod bod regAnnot = do
  si1 <-
    if regIsUnnamed qMeta
      then return mempty
      else do
        l <-
          sequence $
            selectByModifier
              mod
              (writeRegGet structName qMeta regAnnot, writeRegSet structName qMeta regAnnot)
        return $ mconcat l

  si2 <- mapM (writeRegisterBody structName qMeta) bod

  return $ si1 <> fromMaybe mempty si2

structBody :: StructName -> ObjTypeBody Checked I A -> M SIntf
structBody structName (ObjTypeBody _ decls _) = do
  fmap mconcat $ forM decls $ \(Directed _ decl _) ->
    case decl of
      RegisterDecl
        { qRegMeta = Present regMetadata,
          regIdent = Guaranteed (identToString -> i),
          regModifier = Guaranteed mod,
          regBody = bod,
          regAnnot = ann
        } -> do
          let (Present (FieldSpan off sz)) = regSpan regMetadata

          textM $ do
            emitDocComments ann
            tell (sizeToField i sz)
            tell ";\n"

          checkout aF $
            writeStaticAssert structName i off

          checkout iF $
            (if regIsUnnamed regMetadata then id else sIntfSingleton i)
              <$> writeImplementation structName regMetadata mod bod ann
      BufferDecl
        { bufIdent = Guaranteed (identToString -> i),
          bufSize = (trueValue -> size),
          bufAnnot = ann
        } -> do
          textM $ do
            emitDocComments ann
            tell "uint8_t "
            tell (Text.pack i)
            tell "["
            tell $ Text.pack (show size)
            tell "];\n"

          return mempty
      TypeSubStructure
        { subStructureBody = Identity bod,
          subStructureName = mname
        } -> do
          text $
            case objBodyType bod of
              Union {} -> "union "
              Struct {} -> "struct "

          sintf <- body $ structBody structName bod

          textM $ do
            forM_ mname $ \name ->
              tell (Text.pack $ identToString name)

            tell ";\n"

          return sintf
  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 -> M a -> M a
union identifier fn = do
  text "#pragma pack(push, 1)\n"
  text $ "union " <> identifier <> " "
  a <- body fn
  text ";\n"
  text "#pragma pack(pop)\n"
  return a

struct :: Text -> M a -> M a
struct identifier fn = do
  text "#pragma pack(push, 1)\n"
  text $ "struct " <> identifier <> " "
  a <- body fn
  text ";\n"
  text "#pragma pack(pop)\n"
  return a

body :: M a -> M a
body f = text "{\n" *> withIndent f <* textM (ensureNL >> tell "}")

withIndent :: M a -> M a
withIndent = block incIndent decIndent

withCMacroMode :: M a -> M a
withCMacroMode = block cMacroModeStart cMacroModeStop

identifierFor :: (ExportableDecl d) => d -> Text
identifierFor = qualifiedPathToIdentifier . metadataFullyQualifiedPath . getMetadata

emitDocComments :: A -> FormattedWriter ()
emitDocComments (Commented comments _) = do
  mapM_ (\t -> tellLn $ "// " <> trimDocComment t) $
    filter (not . Text.all isSpace) $
      Text.lines $
        mconcat $
          mapMaybe
            ( \case
                (DocComment t) -> Just t
                _ -> Nothing
            )
            comments
  ensureNL
  where
    trimDocComment =
      Text.dropWhileEnd isSpace
        . Text.dropWhile isSpace
        . dropIf (== '*')
        . Text.dropWhile isSpace

    dropIf _ t | Text.null t = mempty
    dropIf fn t =
      if fn (Text.head t)
        then Text.tail t
        else t

getEnumConstants :: [Directed EnumConstantDecl Checked I a] -> [(String, N Unitless, [Directive I a])]
getEnumConstants = mapMaybe $ \case
  Directed dirs (EnumConstantDecl (identToString -> str) (trueValue -> val) _) _ -> Just (str, val, dirs)
  _ -> Nothing

pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless, [Directive I a])] -> FiddleDecl Checked I a
pattern EnumPattern qualifiedPath consts <-
  BitsDecl
    { bitsQualificationMetadata =
        Identity
          ( Present
              ( ExportedBitsDecl
                  { exportedBitsDeclMetadata =
                      Metadata
                        { metadataFullyQualifiedPath = qualifiedPath
                        }
                  }
                )
            ),
      bitsType =
        EnumBitType
          { enumBitBody =
              Identity
                ( EnumBody
                    { enumConsts = getEnumConstants -> consts
                    }
                  )
          }
    }

emitEnum :: QualifiedPath String -> [(String, N Unitless, [Directive I A])] -> M ()
emitEnum (qualifiedPathToIdentifier -> ident) consts = do
  text $ "enum " <> ident <> " "
  body $ do
    forM_ consts $ \(name, val, dirs) -> do
      if isUnqualified dirs
        then
          text $ Text.pack name <> " = " <> Text.pack (show val) <> ",\n"
        else
          text $
            ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n"
  text ";\n\n"
  where
    isUnqualified =
      any
        ( any
            ( \case
                (DirectiveElementKey {directiveKey = identToString -> "unqualified"}) -> True
                _ -> False
            )
            . allElements
        )

    allElements
      ( Directive
          { directiveBody =
              Identity
                ( DirectiveBody
                    { directiveElements = elts
                    }
                  )
          }
        ) = elts

transpileWalk ::
  FilePath ->
  (forall t. (Walk t, Typeable t) => t I A -> () -> M (WalkContinuation ()))
transpileWalk _headerFile t _ = case () of
  ()
    | Just
        ( ObjTypeDecl
            { objTypeQualificationMetadata = Identity metadata,
              objTypeBody = Identity objTypeBody,
              objTypeAnnot = a
            }
          ) <-
        castTS t -> do
        let structureType = case objBodyType objTypeBody of
              Union {} -> union
              Struct {} -> struct

        checkout sF $ do
          pad $ do
            textM $ emitDocComments a
            let structName = identifierFor (unwrap metadata)
            sh <- structureType structName $ do
              structBody structName objTypeBody
            writeSIntf (metadataFullyQualifiedPath $ getMetadata (unwrap metadata)) sh
        return Stop
  () | Just (getExportedObjectDecl -> Just e) <- castTS t -> do
    let qname = qualifiedPathToIdentifier (metadataFullyQualifiedPath (getMetadata e))
    checkout fF $ do
      text "#define "
      text qname
      text $ Text.pack $ printf " ((struct %s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e)

    return Stop
  () | Just (EnumPattern path consts) <- castTS t -> do
    checkout sF $ emitEnum path consts
    return Stop
  () | Just (ImportStatement {importPath = path}) <- castTS t -> do
    let header = fst (Text.breakOnEnd "." path) <> "h"
     in checkout hF $ do
          text $ Text.pack $ printf "#include \"%s\"\n" header
          return Stop
  _ -> return (Continue ())
  where
    toLiteralTypeName :: ReferencedObjectType -> Text
    toLiteralTypeName (ReferencedObjectType str) = qualifiedPathToIdentifier str
    toLiteralTypeName (ArrayObjectType ro _) = toLiteralTypeName ro

    castTS ::
      forall (t' :: SynTree) (t :: StagedSynTree) (f :: Type -> Type) (a :: Type).
      ( Typeable t',
        Typeable t,
        Typeable f,
        Typeable a
      ) =>
      t' f a ->
      Maybe (t Checked f a)
    castTS = cast

    writeSIntf :: QualifiedPath String -> SIntf -> M ()
    writeSIntf qp si = do
      let typename = qualifiedPathToIdentifier qp <> "__intf"

      checkout intfF $ do
        text "typedef "
        sIntfToC si
        text $ " " <> typename <> ";\n\n"

        withCMacroMode $ do
          text $
            "#define "
              <> Text.toUpper (qualifiedPathToIdentifier qp)
              <> "_INTF (("
              <> typename
              <> ")"
          sIntfToRVal si
          text ")"

        text "\n\n"

    getExportedObjectDecl :: FiddleDecl Checked I A -> Maybe ExportedObjectDecl
    getExportedObjectDecl (ObjectDecl {objectQualificationMetadata = Identity (Present decl)}) = Just decl
    getExportedObjectDecl _ = Nothing