diff options
Diffstat (limited to 'Biz/Bild.hs')
| -rw-r--r-- | Biz/Bild.hs | 128 |
1 files changed, 86 insertions, 42 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index cba6539..9868ef0 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -133,12 +133,13 @@ import qualified Data.Conduit as Conduit import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.Process as Conduit import qualified Data.List as List +import qualified Data.Maybe as Maybe import qualified Data.String as String import qualified Data.Text as Text import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit -import System.FilePath ((</>)) +import System.FilePath (replaceExtension, (</>)) import qualified System.IO as IO import qualified Text.Regex.Applicative as Regex import qualified Prelude @@ -209,7 +210,7 @@ data Compiler data Target = Target { -- | Output name - out :: Out, + out :: Maybe Out, -- | Fully qualified namespace partitioned by '.' namespace :: Namespace, -- | Absolute path to file @@ -223,20 +224,38 @@ data Target = Target } deriving (Show) +-- | We can't build everything yet... isBuildableNs :: Namespace -> Bool isBuildableNs (Namespace _ Namespace.Hs) = True +isBuildableNs (Namespace _ Namespace.Scm) = True isBuildableNs ns | ns `elem` nixTargets = True | otherwise = False + where + nixTargets = + [ Namespace ["Biz", "Pie"] Namespace.Nix, + Namespace ["Biz", "Que", "Prod"] Namespace.Nix, + Namespace ["Biz", "Cloud"] Namespace.Nix, + Namespace ["Biz", "Dev"] Namespace.Nix, + Namespace ["Hero", "Prod"] Namespace.Nix + ] + +-- | Emulate the *nix hierarchy in the cabdir. +bindir, intdir, nixdir, vardir :: String +bindir = "_/bin" +intdir = "_/int" +nixdir = "_/nix" +vardir = "_/var" -nixTargets :: [Namespace] -nixTargets = - [ Namespace ["Biz", "Pie"] Namespace.Nix, - Namespace ["Biz", "Que", "Prod"] Namespace.Nix, - Namespace ["Biz", "Cloud"] Namespace.Nix, - Namespace ["Biz", "Dev"] Namespace.Nix, - Namespace ["Hero", "Prod"] Namespace.Nix - ] +createHier :: String -> IO () +createHier root = + mapM_ + (Dir.createDirectoryIfMissing True) + [ root </> bindir, + root </> intdir, + root </> nixdir, + root </> vardir + ] getNamespace :: String -> IO (Maybe Namespace) getNamespace s = do @@ -254,15 +273,14 @@ analyze namespace@(Namespace.Namespace _ ext) = do content <- String.lines </ Prelude.readFile path let out = content - /> Regex.match metaOut + /> Regex.match (metaOut "--") |> catMaybes |> head - |> fromMaybe mempty - let compiler = detectGhcCompiler out <| String.unlines content return Target { deps = content /> Regex.match metaDep |> catMaybes, builder = user <> "@localhost", + compiler = detectGhcCompiler out <| String.unlines content, .. } Namespace.Nix -> @@ -270,7 +288,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do Target { deps = [], compiler = NixBuild, - out = "", + out = Nothing, builder = if host == "lithium" then mempty @@ -284,12 +302,17 @@ analyze namespace@(Namespace.Namespace _ ext) = do ], .. } - Namespace.Scm -> + Namespace.Scm -> do + content <- String.lines </ Prelude.readFile path return Target { deps = [], compiler = Guile, - out = "", + out = + content + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, builder = user <> "@localhost", .. } @@ -298,7 +321,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do Target { deps = [], compiler = Copy, - out = "", + out = Nothing, builder = user <> "@localhost", .. } @@ -310,10 +333,10 @@ analyze namespace@(Namespace.Namespace _ ext) = do -- Detecting a Lib is harder, and much code can be compiled by both ghc and -- ghcjs. For now I'm just guarding against known ghcjs-only modules in the -- import list. -detectGhcCompiler :: String -> String -> Compiler -detectGhcCompiler out _ | jsSuffix out = GhcjsExe -detectGhcCompiler out _ | not <| jsSuffix out || null out = GhcExe -detectGhcCompiler _ content +detectGhcCompiler :: Maybe Out -> String -> Compiler +detectGhcCompiler (Just out) _ | jsSuffix out = GhcjsExe +detectGhcCompiler (Just out) _ | not <| jsSuffix out = GhcExe +detectGhcCompiler Nothing content | match "import GHCJS" = GhcjsLib | otherwise = GhcLib where @@ -333,11 +356,10 @@ isSuccess _ = False build :: Bool -> Bool -> Target -> IO Exit.ExitCode build andTest loud Target {..} = do root <- Env.getEnv "BIZ_ROOT" + createHier root case compiler of GhcExe -> do Log.info ["bild", "dev", "ghc-exe", nschunk namespace] - let outDir = root </> "_/bild/dev/bin" - Dir.createDirectoryIfMissing True outDir exitcode <- proc loud @@ -346,22 +368,22 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path, "-main-is", Namespace.toHaskellModule namespace, "-o", - outDir </> out + root </> bindir </> Maybe.fromJust out ] if andTest && isSuccess exitcode then run <| Proc { loud = loud, - cmd = outDir </> out, + cmd = root </> bindir </> Maybe.fromJust out, args = ["test"], ns = namespace, onFailure = Log.fail ["test", nschunk namespace] >> Log.br, @@ -377,16 +399,14 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path ] GhcjsExe -> do Log.info ["bild", "dev", "ghcjs-exe", nschunk namespace] - let outDir = root </> "_/bild/dev/static" - Dir.createDirectoryIfMissing True outDir proc loud namespace @@ -394,15 +414,15 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path, "-main-is", Namespace.toHaskellModule namespace, "-o", - outDir </> out + root </> vardir </> Maybe.fromJust out ] GhcjsLib -> do Log.info ["bild", "dev", "ghcjs-lib", nschunk namespace] @@ -413,14 +433,40 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path ] Guile -> do - Log.warn ["bild", "guile", "TODO", nschunk namespace] + Log.info ["bild", "dev", "guile", nschunk namespace] + proc + loud + namespace + "guild" + [ "compile", + "--load-path=" ++ root, + "--output=" ++ root </> intdir </> replaceExtension path ".scm.go", + path + ] + when (isJust out) <| do + let o = Maybe.fromJust out + writeFile + (root </> bindir </> o) + <| Text.pack + <| joinWith + "\n" + [ "#!/usr/bin/env bash", + "guile -C \"" + <> root </> intdir + <> "\" -c \"(use-modules " + <> Namespace.toSchemeModule namespace + <> ") (main (command-line))\"" + <> " \"$@\"" + ] + p <- Dir.getPermissions <| root </> bindir </> o + Dir.setPermissions (root </> bindir </> o) (Dir.setOwnerExecutable True p) return Exit.ExitSuccess NixBuild -> do Log.info @@ -431,15 +477,13 @@ build andTest loud Target {..} = do else builder, nschunk namespace ] - let outDir = root </> "_/bild/nix" - Dir.createDirectoryIfMissing True outDir proc loud namespace "nix-build" [ path, "-o", - outDir </> Namespace.toPath namespace, + root </> nixdir </> Namespace.toPath namespace, "--builders", Text.unpack builder ] @@ -497,5 +541,5 @@ nschunk = Namespace.toPath .> Text.pack metaDep :: Regex.RE Char Dep metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha) -metaOut :: Regex.RE Char Out -metaOut = Regex.string "-- : out " *> Regex.many (Regex.psym (/= ' ')) +metaOut :: [Char] -> Regex.RE Char Out +metaOut comment = Regex.string (comment ++ " : out ") *> Regex.many (Regex.psym (/= ' ')) |