diff options
Diffstat (limited to 'Biz/Bild.hs')
| -rw-r--r-- | Biz/Bild.hs | 141 |
1 files changed, 115 insertions, 26 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 23086a7..96f63ad 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -6,12 +6,9 @@ -- | A general purpose build tool. -- --- Not all of the below design is implemented. Currently: --- --- - with a nix build, results are linked in _/bild/nix/<target> --- - with a dev build, results are stored in _/bild/dev/<target> --- --- ----------------------------------------------------------------------------- +-- : out bild +-- : dep docopt +-- : dep regex-applicative -- -- == Design constraints -- @@ -119,7 +116,7 @@ module Biz.Bild where import Alpha hiding (sym, (<.>)) -import Biz.Namespace (Namespace) +import Biz.Namespace (Namespace (..)) import qualified Biz.Namespace as Namespace import qualified Data.Char as Char import qualified Data.List as List @@ -137,8 +134,11 @@ main :: IO () main = Env.getArgs >>= Docopt.parseArgsOrExit help >>= run where run args = - Docopt.getAllArgs args (Docopt.argument "target") - |> mapM_ (\target -> analyze target >>= build) + mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target")) + /> catMaybes + /> filter isBuildableNs + >>= mapM analyze + >>= mapM_ build help :: Docopt.Docopt help = @@ -156,7 +156,14 @@ type Dep = String type Out = String -data Compiler = Ghc | Ghcjs | Guile | NixBuild +data Compiler + = GhcLib + | GhcExe + | GhcjsLib + | GhcjsExe + | Guile + | NixBuild + | Copy deriving (Show) data Target = Target @@ -175,20 +182,42 @@ data Target = Target } deriving (Show) -analyze :: String -> IO Target -analyze s = do - user <- Env.getEnv "USER" +isBuildableNs :: Namespace -> Bool +isBuildableNs (Namespace _ Namespace.Hs) = True +isBuildableNs ns + | ns `elem` nixTargets = True + | otherwise = False + +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 + ] + +getNamespace :: String -> IO (Maybe Namespace) +getNamespace s = do root <- Env.getEnv "BIZ_ROOT" - host <- chomp </ readFile "/etc/hostname" cwd <- Dir.getCurrentDirectory - let path = cwd </> s - let namespace@(Namespace.Namespace _ ext) = - require "namespace" <| Namespace.fromPath root path + return <| Namespace.fromPath root <| cwd </> s + +analyze :: Namespace -> IO Target +analyze namespace@(Namespace.Namespace _ ext) = do + user <- Env.getEnv "USER" + host <- chomp </ readFile "/etc/hostname" + let path = Namespace.toPath namespace case ext of Namespace.Hs -> do content <- String.lines </ Prelude.readFile path - let out = content /> Regex.match metaOut |> catMaybes |> head |> require "out" - let compiler = if ".js" `List.isSuffixOf` out then Ghcjs else Ghc + let out = + content + /> Regex.match metaOut + |> catMaybes + |> head + |> fromMaybe mempty + let compiler = detectGhcCompiler out <| String.unlines content return Target { deps = content /> Regex.match metaDep |> catMaybes, @@ -223,13 +252,41 @@ analyze s = do builder = user <> "@localhost", .. } + _ -> + return + Target + { deps = [], + compiler = Copy, + out = "", + builder = user <> "@localhost", + .. + } + +-- | Some rules for detecting the how to compile a ghc module. If there is an +-- out, then we know it's some Exe; if the out ends in .js then it's GhcjsExe, +-- otherwise GhcExe. That part is solved. +-- +-- 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 + | match "import GHCJS" = GhcjsLib + | otherwise = GhcLib + where + match s = s `List.isInfixOf` content + +jsSuffix :: String -> Bool +jsSuffix = List.isSuffixOf ".js" build :: Target -> IO () build target@Target {..} = do root <- Env.getEnv "BIZ_ROOT" case compiler of - Ghc -> do - putText <| "bild: dev: ghc: " <> Namespace.toPath namespace + GhcExe -> do + putStrLn <| "bild: dev: ghc-exe: " <> Namespace.toPath namespace let outDir = root </> "_/bild/dev/bin" Dir.createDirectoryIfMissing True outDir putText <| "bild: dev: bilder: " <> Text.pack builder @@ -248,8 +305,22 @@ build target@Target {..} = do "-o", outDir </> out ] - Ghcjs -> do - putText <| "bild: dev: ghcjs: " <> Namespace.toPath namespace + GhcLib -> do + putStrLn <| "bild: dev: ghc-lib: " <> Namespace.toPath namespace + putText <| "bild: dev: bilder: " <> Text.pack builder + Process.callProcess + "ghc" + [ "-Werror", + "-i" <> root, + "-odir", + root </> "_/bild/int", + "-hidir", + root </> "_/bild/int", + "--make", + path + ] + GhcjsExe -> do + putStrLn <| "bild: dev: ghcjs-exe: " <> Namespace.toPath namespace let outDir = root </> "_/bild/dev/static" Dir.createDirectoryIfMissing True outDir putText <| "bild: dev: local: " <> Text.pack builder @@ -268,13 +339,27 @@ build target@Target {..} = do "-o", outDir </> out ] + GhcjsLib -> do + putStrLn <| "bild: dev: ghcjs-lib: " <> Namespace.toPath namespace + putText <| "bild: dev: local: " <> Text.pack builder + Process.callProcess + "ghcjs" + [ "-Werror", + "-i" <> root, + "-odir", + root </> "_/bild/int", + "-hidir", + root </> "_/bild/int", + "--make", + path + ] Guile -> do - putText <| "bild: dev: guile: " <> Namespace.toPath namespace + putStrLn <| "bild: dev: guile: " <> Namespace.toPath namespace putText <| "bild: dev: local: " <> Text.pack builder putText "bild: guile TODO" putText <| show target NixBuild -> do - putText <| "bild: nix: " <> Namespace.toPath namespace + putStrLn <| "bild: nix: " <> Namespace.toPath namespace let outDir = root </> "_/bild/nix" Dir.createDirectoryIfMissing True outDir if null builder @@ -284,7 +369,7 @@ build target@Target {..} = do "nix-build" [ path, "-o", - outDir </> (Text.unpack <| Namespace.toPath namespace), + outDir </> Namespace.toPath namespace, -- Set default arguments to nix functions "--arg", "bild", @@ -300,6 +385,10 @@ build target@Target {..} = do "--builders", builder ] + Copy -> do + putStrLn <| "bild: copy: " <> Namespace.toPath namespace + putText "bild: copy TODO" + putText <| show target metaDep :: Regex.RE Char Dep metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha) |