Add backend support and start implementing a C backend.o

8 files changed, 475 insertions, 40 deletions

diff --git a/Main.hs b/Main.hs
index 97be0a3..0cdba7a 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,5 +1,7 @@
 module Main where
 
+import Data.List (isPrefixOf)
+import Control.Category ((>>>))
 import Control.Monad (forM_, when)
 import Control.Monad.Identity (Identity)
 import Data.Aeson (ToJSON (..), Value (..), encode)
@@ -9,6 +11,8 @@ import Data.Typeable
 import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
+import Language.Fiddle.Compiler.Backend
+import Language.Fiddle.Compiler.Backend.C
 import Language.Fiddle.Compiler.ConsistencyCheck
 import Language.Fiddle.Compiler.Expansion
 import Language.Fiddle.Compiler.ImportResolution
@@ -17,10 +21,10 @@ import Language.Fiddle.Compiler.Stage0
 import Language.Fiddle.GenericTree
 import Language.Fiddle.Types (Commented (unCommented), SourceSpan)
 import Options.Applicative
+import Options.Applicative.Types (ParserHelp (..))
 import qualified System.Environment as System
 import System.Exit (exitWith)
-import System.IO (stderr, hPutStrLn)
-import Control.Category ((>>>))
+import System.IO (hPutStrLn, stderr)
 
 newtype IntermediateAst = IntermediateAst (GenericSyntaxTree Identity (Maybe Value))
   deriving (Typeable)
@@ -85,7 +89,8 @@ dumpPhase stageName =
 -- | Global flags for the compiler.
 data GlobalFlags = GlobalFlags
   { flagsInputFile :: String,
-    flagsDiagnosticFormat :: DiagnosticFormat
+    flagsDiagnosticFormat :: DiagnosticFormat,
+    flagsBackend :: String
   }
 
 -- | Parse global flags from command line arguments.
@@ -93,10 +98,18 @@ parseGlobalFlags :: Parser GlobalFlags
 parseGlobalFlags =
   GlobalFlags
     <$> argument str (metavar "INPUT" <> help "Input file")
-    <*> ((\b -> if b then jsonDiagnosticFormat else coloredFormat) <$> switch
-      ( long "diagnostics-as-json"
-          <> help "Dump diagnostics in JSON format."
-      ))
+    <*> ( (\b -> if b then jsonDiagnosticFormat else coloredFormat)
+            <$> switch
+              ( long "diagnostics-as-json"
+                  <> help "Dump diagnostics in JSON format."
+              )
+        )
+    <*> strOption
+      ( long "language"
+          <> short 'L'
+          <> help "The output language"
+          <> metavar "LANGUAGE"
+      )
 
 -- | Parse the input file into the initial AST stages.
 doParse :: String -> IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
@@ -111,7 +124,7 @@ runCompilationPipeline ::
   IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
 runCompilationPipeline argv tree =
   case fromArgs argv of
-    Success (_, pipelineAction) -> pipelineAction tree
+    Success (_, pipelineAction, _) -> pipelineAction tree
     _ ->
       return
         ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)],
@@ -125,36 +138,71 @@ fromArgs ::
   ParserResult
     ( GlobalFlags,
       TreeType FiddleUnit Parsed ->
-      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
+      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)),
+      FiddleUnit Checked Identity (Commented SourceSpan) -> IO TranspileResult
     )
 fromArgs argv =
-  execParserPure
-    defaultPrefs
-    ( info
-        ( (,)
+  case selectBackend argv of
+    Just backend -> do
+      execParserPure
+        defaultPrefs
+        (parserInfo backend)
+        argv
+    Nothing ->
+      Failure $
+        parserFailure
+          defaultPrefs
+          (parserInfo nullBackend)
+          (ErrorMsg "Unknown backend")
+          mempty
+  where
+    selectBackend :: [String] -> Maybe Backend
+    selectBackend argv = selectBackendEq argv <|> selectBackendSpace argv
+
+    selectBackendEq argv =
+       case filter ("--language="`isPrefixOf`) argv of
+          [backend] -> case break (=='=') backend of
+             (_, '=' : s) -> selectBackendFromString s
+             _ -> Nothing
+          _ -> Nothing
+
+    selectBackendSpace argv =
+      case break (\s -> s == "--language" || "-L" `isPrefixOf` s) argv of
+        (_, "--language" : s : _) -> selectBackendFromString s
+        (_, "-L" : s : _) -> selectBackendFromString s
+        (_, ('-' : 'L' : s) : _) -> selectBackendFromString s
+        _ -> Nothing
+
+    selectBackendFromString "c" = Just cBackend
+    selectBackendFromString "null" = Just nullBackend
+    selectBackendFromString _ = Nothing
+         
+
+    parserInfo backend =
+      info
+        ( (,,)
             <$> parseGlobalFlags
             <*> execCompilationPipelineWithCmdline
               (compilationPipeline doParse (runCompilationPipeline argv))
+            <*> backendToParserFunction backend
               <**> helper
         )
         ( fullDesc
             <> progDesc "Compile Fiddle Files"
             <> header "fiddlec - A compiler for Fiddle files"
         )
-    )
-    argv
 
 main :: IO ()
 main = do
   argv <- System.getArgs
-  (globalFlags, compilationAction) <- parseCommandLineArgs argv
+  (globalFlags, compilationAction, backendAction) <- parseCommandLineArgs argv
   let filePath = flagsInputFile globalFlags
 
   maybeParsedAst <- parseInputFile filePath
   case maybeParsedAst of
     (priorDiags, _, Just ast) -> do
       ((priorDiags ++) -> diags, artifacts, ma) <- compilationAction ast
-      exitCode <- processCompilationResult artifacts ma
+      exitCode <- processCompilationResult artifacts ma backendAction
       printDiagnostics (flagsDiagnosticFormat globalFlags) diags
       exitWith exitCode
     (diags, _, _) ->
@@ -166,7 +214,8 @@ parseCommandLineArgs ::
   IO
     ( GlobalFlags,
       TreeType FiddleUnit Parsed ->
-      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
+      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)),
+      FiddleUnit Checked Identity (Commented SourceSpan) -> IO TranspileResult
     )
 parseCommandLineArgs argv = handleParseResult (fromArgs argv)
 
@@ -177,8 +226,11 @@ parseInputFile filePath = do
   return $ compile_ $ toStage0 filePath text >>= toStage1
 
 -- | Process the compilation result, printing the output and returning the exit code.
-processCompilationResult :: [Artifact] -> Maybe (TreeType FiddleUnit Checked) -> IO ExitCode
-processCompilationResult artifacts ma = do
+processCompilationResult ::
+  [Artifact] -> Maybe (TreeType FiddleUnit Checked) -> 
+   (TreeType FiddleUnit Checked -> IO TranspileResult)
+  -> IO ExitCode
+processCompilationResult artifacts ma backendFunction = do
   forM_ artifacts $ \case
     Artifact (cast -> (Just (IntermediateAst ast))) ->
       putStrLn $
@@ -188,7 +240,8 @@ processCompilationResult artifacts ma = do
     Artifact _ -> return ()
 
   case ma of
-    Just _ -> do
+    Just ast -> do
+      processTranspileResult =<< backendFunction ast
       return ExitSuccess
     Nothing -> do
       return (ExitFailure 1)
diff --git a/package.yaml b/package.yaml
index ec9bf4c..6d5825c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -14,6 +14,8 @@ library:
     - Language.Fiddle.Ast
     - Language.Fiddle.Compiler
     - Language.Fiddle.Types
+    - Language.Fiddle.Compiler.Backend
+    - Language.Fiddle.Compiler.Backend.C
     - Language.Fiddle.Compiler.ConsistencyCheck
     - Language.Fiddle.Compiler.Expansion
     - Language.Fiddle.Compiler.ImportResolution
diff --git a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
index 221dd5b..fc77e1f 100644
--- a/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
+++ b/src/Language/Fiddle/Ast/Internal/Instances/Walk.hs
@@ -1,26 +1,30 @@
-module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_) where
+module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_, WalkContinuation (..)) where
 
 import Data.Typeable
 import GHC.Generics
 
--- | Like walk, but assumes no local state.
+-- | Like walk, but assumes no local state and always continue
 walk_ ::
   (Monad m, Traversable f, Typeable f, Typeable a, Walk t) =>
   (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> m ()) ->
   t f a ->
   m ()
-walk_ fn t = walk (\t _ -> fn t) t ()
+walk_ fn t = walk (\t _ -> fn t >> return (Continue ())) t ()
+
+data WalkContinuation s where
+  Continue :: s -> WalkContinuation s
+  Stop :: WalkContinuation s
 
 class (Typeable t) => Walk t where
   walk ::
     (Monad m, Traversable f, Typeable f, Typeable a) =>
-    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m s) ->
+    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
     t f a ->
     s ->
     m ()
   default walk ::
     (GWalk (Rep (t f a)) f a, Generic (t f a), Monad m, Traversable f, Typeable f, Typeable a) =>
-    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m s) ->
+    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
     t f a ->
     s ->
     m ()
@@ -29,7 +33,7 @@ class (Typeable t) => Walk t where
 class GWalk r f a where
   gwalk ::
     (Monad m, Typeable f, Typeable a, Traversable f) =>
-    (forall t'. (Walk t', Typeable t') => t' f a -> s -> m s) ->
+    (forall t'. (Walk t', Typeable t') => t' f a -> s -> m (WalkContinuation s)) ->
     r x ->
     s ->
     m ()
@@ -63,8 +67,11 @@ instance
   GWalk (Rec0 (t f a)) f a
   where
   gwalk fn (K1 k) s = do
-    s' <- fn k s
-    walk fn k s'
+    ( \case
+        Continue s' -> walk fn k s'
+        _ -> return ()
+      )
+      =<< fn k s
 
 instance
   ( Traversable f,
@@ -76,8 +83,11 @@ instance
   gwalk fn (K1 fk) s = do
     mapM_
       ( \tfa -> do
-          s' <- fn tfa s
-          walk fn tfa s'
+          ( \case
+              Continue s' -> walk fn tfa s'
+              _ -> return ()
+            )
+            =<< fn tfa s
       )
       fk
 
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
index 1e9ace7..f627f15 100644
--- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -222,12 +222,17 @@ instance
   Walk (Directed t stage)
   where
   walk fn (Directed directives subtree _) s = do
-    s' <- fn subtree s
-    walk fn subtree s'
-
-    forM_ directives $ \d -> do
-      s' <- fn d s
-      walk fn d s'
+    forM_ directives $ \d ->
+      ( \case
+          Continue s' -> walk fn d s'
+          _ -> return ()
+      )
+        =<< fn d s
+    ( \case
+        Continue s' -> walk fn subtree s'
+        _ -> return ()
+      )
+      =<< fn subtree s
 
 -- | Apply a function to the underlying subtree in a 'Directed' type.
 mapDirected :: (t s f a -> t' s' f a) -> Directed t s f a -> Directed t' s' f a
diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 571c7b0..afe8f64 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -201,6 +201,7 @@ coloredFormat = DiagnosticFormat $ \diags ->
 -- | Prints a list of diagnostics to 'stderr' using the specified
 -- diagnostic format.
 printDiagnostics :: DiagnosticFormat -> [Diagnostic] -> IO ()
+printDiagnostics _ [] = return ()
 printDiagnostics fmt d = hPutStrLn stderr (diagnosticsToString fmt d)
 
 -- | Prints a single diagnostic to 'stderr' using the 'coloredFormat'
diff --git a/src/Language/Fiddle/Compiler/Backend.hs b/src/Language/Fiddle/Compiler/Backend.hs
new file mode 100644
index 0000000..ddb32c6
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend.hs
@@ -0,0 +1,81 @@
+module Language.Fiddle.Compiler.Backend where
+
+import Control.Monad (forM_)
+import Control.Monad.Identity (Identity)
+import Control.Monad.Writer
+import Data.Map (Map)
+import qualified Data.Text.IO
+import qualified Data.Map as Map
+import Data.Text (Text)
+import Language.Fiddle.Ast
+import Language.Fiddle.Types (Commented, SourceSpan)
+import Options.Applicative
+
+-- | Data representing the result of transpilation.
+data TranspileResult where
+  TranspileResult ::
+    { newFileContents :: Map FilePath Text
+    } ->
+    TranspileResult
+
+instance Semigroup TranspileResult where
+  (<>) (TranspileResult c1) (TranspileResult c2) =
+    TranspileResult $ Map.unionWith (<>) c1 c2
+
+instance Monoid TranspileResult where
+  mempty = TranspileResult mempty
+
+-- | "Opens" a file in the broader context of a TransplieResult, and writes the
+-- resulting bytestring to it
+withFile ::
+  (MonadWriter TranspileResult m) => FilePath -> Writer Text () -> m ()
+withFile path bsWriter =
+  tell (TranspileResult $ Map.singleton path $ execWriter bsWriter)
+
+-- | A backend for the FiddleCompiler. Takes a Checked FiddleUnit and emits
+-- generated code for that fiddle unit.
+data Backend where
+  Backend ::
+    forall privateFlags privateState.
+    { backendName :: String,
+      backendOptionsParser :: Parser privateFlags,
+      backendIOMakeState :: privateFlags -> IO privateState,
+      backendTranspile ::
+        privateFlags ->
+        privateState ->
+        FiddleUnit Checked Identity (Commented SourceSpan) ->
+        TranspileResult
+    } ->
+    Backend
+
+backendToParserFunction ::
+  Backend ->
+  Parser
+    ( FiddleUnit Checked Identity (Commented SourceSpan) -> IO TranspileResult
+    )
+backendToParserFunction
+  Backend
+    { backendOptionsParser = optionsParser,
+      backendIOMakeState = ioMakeState,
+      backendTranspile = transpile
+    } =
+    ( \opts ->
+        let ioState = ioMakeState opts
+         in \fiddleUnit -> do
+              state <- ioState
+              return $ transpile opts state fiddleUnit
+    )
+      <$> optionsParser
+
+processTranspileResult :: TranspileResult -> IO ()
+processTranspileResult (TranspileResult mp) =
+  forM_ (Map.toList mp) $ \(file, text) ->
+    Data.Text.IO.writeFile file text
+
+nullBackend :: Backend
+nullBackend = Backend {
+  backendName = "null",
+  backendOptionsParser = pure (),
+  backendIOMakeState = const $ return (),
+  backendTranspile = \_ _ _ -> mempty 
+}
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs
new file mode 100644
index 0000000..5379099
--- /dev/null
+++ b/src/Language/Fiddle/Compiler/Backend/C.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+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)
+import Data.Kind (Type)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.String (IsString)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.Fiddle.Ast
+import Language.Fiddle.Compiler.Backend
+import Language.Fiddle.Internal.UnitInterface
+import Language.Fiddle.Types
+import Options.Applicative
+
+data ImplementationInHeader = ImplementationInHeader
+
+data CBackendFlags = CBackendFlags
+  { cSourceOut :: Either ImplementationInHeader FilePath,
+    cHeaderOut :: FilePath
+  }
+
+data FilePosition = FilePosition Int
+  deriving (Eq, Ord)
+
+headerPos = FilePosition 0
+
+middlePos = FilePosition 50
+
+footerPos = FilePosition 100
+
+tellLn :: (MonadWriter Text m) => Text -> m ()
+tellLn s = tell s >> tell "\n"
+
+type A = Commented SourceSpan
+
+type I = Identity
+
+-- | Current local state information while traversing the tree.
+data St = St
+  { indentLevel :: Int,
+    pendingLine :: Text
+  }
+
+newtype M a = M {unM :: RWS () () (St, Files) a}
+  deriving newtype (Functor, Applicative, Monad, MonadState (St, Files))
+
+newtype FormattedWriter a = FormattedWriter (RWS () Text St a)
+  deriving newtype (Functor, Applicative, Monad, MonadState St)
+
+indented :: FormattedWriter a -> FormattedWriter a
+indented fn = do
+  modify (\(St id p) -> St (id + 1) p)
+  fn <* modify (\(St id p) -> St (id - 1) p)
+
+execFormattedWriter :: FormattedWriter a -> Text
+execFormattedWriter ((>> flush) -> FormattedWriter rws) = snd $ execRWS rws () (St 0 "")
+
+flush :: FormattedWriter ()
+flush = do
+  p <- gets pendingLine
+  modify $ \s -> s {pendingLine = ""}
+  tell p
+
+data Files = Files
+  { filepaths :: Map FilePath (Map FilePosition (FormattedWriter ()))
+  }
+
+withFileAt :: FilePath -> FilePosition -> FormattedWriter () -> M ()
+withFileAt fp pos wr = do
+  modify
+    ( second $ \(Files {filepaths = fps}) ->
+        Files
+          { filepaths =
+              Map.alter
+                ( \(fromMaybe mempty -> posMap) ->
+                    Just $
+                      Map.alter (Just . (>> wr) . fromMaybe (return ())) pos posMap
+                )
+                fp
+                fps
+          }
+    )
+
+instance MonadWriter Text FormattedWriter where
+  tell txt = FormattedWriter $ do
+    indent <- (`Text.replicate` "  ") <$> gets indentLevel
+    let lines = Text.splitOn "\n" txt
+    forM_ (init lines) $ \line -> do
+      pending <- gets pendingLine
+      modify $ \s -> s {pendingLine = ""}
+      tell indent
+      tell pending
+      tell line
+      tell "\n"
+    modify $ \s -> s {pendingLine = last lines}
+
+  listen (FormattedWriter fn) = FormattedWriter $ listen fn
+
+  pass (FormattedWriter fn) = FormattedWriter $ pass fn
+
+cBackend :: Backend
+cBackend =
+  Backend
+    { backendName = "C",
+      backendOptionsParser =
+        CBackendFlags
+          <$> ( Right
+                  <$> strOption
+                    ( long "c-source-out"
+                        <> short 'o'
+                        <> help "Output file for the C source file."
+                        <> metavar "OUTPUT"
+                    )
+                    <|> flag'
+                      (Left ImplementationInHeader)
+                      ( long "impl-in-header"
+                          <> help "Put the whole implementation as static inline functions in the header."
+                      )
+              )
+          <*> strOption
+            ( long "c-header-out"
+                <> short 'h'
+                <> help "Output file for the C header file."
+                <> metavar "HEADER_OUT"
+            ),
+      backendIOMakeState = const $ return (),
+      backendTranspile = transpile
+    }
+
+toTranspileResult :: Files -> TranspileResult
+toTranspileResult Files {filepaths = fps} =
+  TranspileResult $
+    fmap
+      ( execFormattedWriter
+          . sequence_
+          . Map.elems
+      )
+      fps
+
+transpile ::
+  CBackendFlags ->
+  () ->
+  FiddleUnit Checked Identity (Commented SourceSpan) ->
+  TranspileResult
+transpile
+  CBackendFlags
+    { cHeaderOut = headerFile,
+      cSourceOut = sourceFile
+    }
+  ()
+  fiddleUnit = toTranspileResult . snd . fst $ execRWS (unM run) () (St 0 "", Files mempty)
+    where
+      run :: M ()
+      run = do
+        withFileAt headerFile headerPos $ do
+          tell $ "#ifndef " <> headerGuard <> "\n"
+          tell $ "#define " <> headerGuard <> "\n"
+
+        walk (transpileWalk sourceFile headerFile) fiddleUnit ()
+        withFileAt headerFile footerPos $ tell headerFinal
+
+        withFileAt headerFile headerPos $ do
+          tell "\n#include <stdint.h>\n"
+
+          tell "\nstatic_assert(true); // https://github.com/clangd/clangd/issues/1167\n"
+
+      headerFinal = "\n#endif /* " <> headerGuard <> " */\n"
+
+      headerGuard =
+        Text.toUpper $
+          Text.replace "." "_" $
+            Text.replace "/" "_" $
+              Text.pack headerFile
+
+class IsText t where
+  toText :: t -> Text
+
+instance IsText String where
+  toText = Text.pack
+
+instance IsText Text where
+  toText = id
+
+qualifiedPathToIdentifier :: (Foldable f, IsText t) => f t -> Text
+qualifiedPathToIdentifier = Text.intercalate "_" . map toText . toList
+
+ensureNL :: FormattedWriter ()
+ensureNL = do
+  p <- gets pendingLine
+  if Text.null p
+    then return ()
+    else do
+      modify $ \s -> s {pendingLine = ""}
+      tell p
+      tell "\n"
+
+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 ()
+
+struct :: Text -> FormattedWriter () -> FormattedWriter ()
+struct identifier fn = do
+  tell "#pragma pack(push, 1)\n"
+  tell $ "struct " <> identifier <> " "
+  body fn
+  tell ";\n"
+  tell "#pragma pack(pop)\n"
+
+body :: FormattedWriter a -> FormattedWriter a
+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 _) =
+  mapM_ (\t -> tellLn $ "// " <> t) $
+    mapMaybe
+      ( \case
+          (DocComment t) -> Just (trimDocComment t)
+          _ -> Nothing
+      )
+      comments
+  where
+    trimDocComment =
+      Text.dropWhileEnd isSpace
+        . Text.dropWhile isSpace
+        . dropIf (== '*')
+        . Text.dropWhile isSpace
+
+    dropIf fn 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
+  ()
+    | Just
+        ( ObjTypeDecl
+            { objTypeQualificationMetadata = Identity metadata,
+              objTypeIdent = (identToString -> identifier),
+              objTypeBody = Identity objTypeBody,
+              objTypeAnnot = a
+            }
+          ) <-
+        castTS t -> do
+        withFileAt headerFile middlePos $ do
+          pad $ do
+            emitDocComments a
+            struct (identifierFor metadata) $ do
+              structBody objTypeBody
+        return Stop
+  _ -> return (Continue ())
+  where
+    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
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index f3ddee0..6ecfc86 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -12,6 +12,7 @@ import qualified Codec.Compression.GZip as GZip
 import Control.Arrow (Arrow (second))
 import Control.Monad (filterM, when)
 import Control.Monad.Identity (Identity)
+import Control.Monad.State (put)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
 import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (..), execWriterT)
 import Data.Aeson (eitherDecode, encode)
@@ -31,7 +32,6 @@ import Options.Applicative
 import System.Directory
 import System.FilePath
 import Text.Printf (printf)
-import Control.Monad.State (put)
 
 newtype Flags = Flags
   { importDirectories :: [FilePath]
@@ -168,8 +168,8 @@ getImportResolutionState parseFile compileToChecked flags unit = do
     $ execWriterT
     $ walk doWalk unit ()
   where
-    doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ([Diagnostic], ResolvedImports) IO ()
-    doWalk u () =
+    doWalk :: forall t'. (Walk t', Typeable t') => t' Identity Annot -> () -> WriterT ([Diagnostic], ResolvedImports) IO (WalkContinuation ())
+    doWalk u () = do
       case () of
         ()
           | Just
@@ -184,6 +184,7 @@ getImportResolutionState parseFile compileToChecked flags unit = do
                   ResolvedImports $ Map.singleton path (diagnostics, unitInterface)
                 )
         _ -> return ()
+      return $ Continue ()
 
     castTS ::
       ( Typeable t',