blob: ec12592bb797788bbe2b4307648962f4fc657ce1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
import Data.Functor (($>))
import Data.Maybe (catMaybes)
import System.Environment (getArgs)
import System.Exit (exitFailure)
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
args <- getArgs
case args of
[dir] -> generate dir
_ -> do putStrLn "Usage: highway-protocols-codegen <protocols-dir>"
exitFailure
generate :: FilePath -> IO ()
generate dir = do
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 <- catMaybes <$> mapM readProtocol protocolSpecs
let typedProtocols = fmap resolveTypes protocols
mapM_ (writeProtocol (flattenModules typedProtocols) codeDir) typedProtocols
writeBuild buildPath protocols
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")
let cfg = GeneratorConfig { genModules = flat
, genProtocol = p
, genInterface = fst i
, genTypes = snd i
}
writeFile path (generateInterface cfg)
writeFile bootPath (generateInterfaceBoot cfg)
writeBuild :: FilePath -> [Protocol] -> IO ()
writeBuild path ps = writeFile path $ generateBuild ps
|
