wip codegen

1 files changed, 34 insertions, 7 deletions

diff --git a/protocols/codegen/Main.hs b/protocols/codegen/Main.hs
index 98e9d62..dbe1577 100644
--- a/protocols/codegen/Main.hs
+++ b/protocols/codegen/Main.hs
@@ -1,9 +1,14 @@
+import Data.Functor (($>))
+import Data.Maybe (catMaybes)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.Directory (listDirectory)
+import System.Directory (listDirectory, createDirectoryIfMissing)
 import System.FilePath ((</>), takeExtension)
 import Wayland.CodeGen.Types
 import Wayland.CodeGen.Parser
+import Wayland.CodeGen.Utils
+import Wayland.CodeGen.BuildGen
+import Wayland.CodeGen.CodeGen
 
 main :: IO ()
 main = do
@@ -15,11 +20,33 @@ main = do
 
 generate :: FilePath -> IO ()
 generate dir = do
-  let srcDir = dir </> "src"
+  let srcDir    = dir </> "src"
+  let codeDir   = dir </> "Wayland" </> "Protocols"
+  let buildPath = dir </> "protocols.cabal"
   protocolSpecs <- filter (\p -> takeExtension p == ".xml") . fmap (srcDir </>) <$> listDirectory srcDir
-  protocols <- mapM readProtocol protocolSpecs
-  print protocols
-  pure ()
+  protocols     <- catMaybes <$> mapM readProtocol protocolSpecs
+  let typedProtocols = fmap resolveTypes protocols
+  mapM_ (writeProtocol (flattenModules typedProtocols) codeDir) typedProtocols
+  writeBuild buildPath protocols
 
-readProtocol :: FilePath -> IO (Either String Protocol)
-readProtocol path = parseProtocolSpec <$> readFile path
+readProtocol :: FilePath -> IO (Maybe Protocol)
+readProtocol path = readFile path >>= handleError . parseProtocolSpec
+  where handleError :: Either String Protocol -> IO (Maybe Protocol)
+        handleError (Left err)   = putStrLn (show path ++ ": " ++ err) $> Nothing
+        handleError (Right prot) = pure (Just prot)
+
+writeProtocol :: FlatModules -> FilePath -> TypedProtocol -> IO ()
+writeProtocol flat baseDir p = do
+  let dir = baseDir </> protocolModule p
+  createDirectoryIfMissing True dir
+  mapM_ (writeInterface flat dir p) (protInterfaces p)
+
+writeInterface :: FlatModules -> FilePath -> TypedProtocol -> TypedInterfaceDesc -> IO ()
+writeInterface flat dir p i = do
+  let path     = dir </> (interfaceModule (fst i) ++ ".hs")
+  let bootPath = dir </> (interfaceModule (fst i) ++ ".hs-boot")
+  writeFile path (generateInterface flat p i)
+  writeFile bootPath (generateInterfaceBoot flat p i)
+
+writeBuild :: FilePath -> [Protocol] -> IO ()
+writeBuild path ps = writeFile path $ generateBuild ps