From 609a119e934630954773a2c53b6a8e51f66c17ca Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 9 Dec 2020 13:26:00 -0500 Subject: Add Biz.Namespace library --- Biz/Bild.hs | 74 ++++++++++++-------------------------------------------- Biz/Namespace.hs | 54 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+), 59 deletions(-) create mode 100644 Biz/Namespace.hs (limited to 'Biz') diff --git a/Biz/Bild.hs b/Biz/Bild.hs index c1cd24f..c55693d 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -119,6 +119,8 @@ module Biz.Bild where import Alpha hiding (sym, (<.>)) +import Biz.Namespace (Namespace) +import qualified Biz.Namespace as Namespace import qualified Data.Char as Char import qualified Data.List as List import qualified Data.String as String @@ -127,7 +129,6 @@ import qualified System.Console.Docopt as Docopt import qualified System.Directory as Dir import qualified System.Environment as Env import System.FilePath (()) -import qualified System.FilePath as File import qualified System.Process as Process import qualified Text.Regex.Applicative as Regex import qualified Prelude @@ -151,12 +152,6 @@ Options: -v, --verbose Show output from underlying compiler |] -data Ext = Hs | Scm | Nix - deriving (Show) - -data Namespace = Namespace [String] Ext - deriving (Show) - type Dep = String type Out = String @@ -187,14 +182,10 @@ analyze s = do host <- chomp s - namespace = - require "namespace" - <| path - |> reps root "" - |> List.stripPrefix "/" - >>= Regex.match metaNamespace - case File.takeExtension path of - ".hs" -> do + let namespace@(Namespace.Namespace _ ext) = + require "namespace" <| Namespace.fromPath root path + case ext of + Namespace.Hs -> do content <- String.lines Regex.match metaOut |> catMaybes |> head |> require "out" let compiler = if ".js" `List.isSuffixOf` out then Ghcjs else Ghc @@ -204,7 +195,7 @@ analyze s = do builder = user <> "@localhost", .. } - ".nix" -> + Namespace.Nix -> return Target { deps = [], @@ -223,7 +214,7 @@ analyze s = do ], .. } - ".scm" -> + Namespace.Scm -> return Target { deps = [], @@ -232,14 +223,13 @@ analyze s = do builder = user <> "@localhost", .. } - e -> panic <| "bild does not know this extension: " <> Text.pack e build :: Target -> IO () build target@Target {..} = do root <- Env.getEnv "BIZ_ROOT" case compiler of Ghc -> do - putText <| "bild: dev: ghc: " <> nsToPath namespace + putText <| "bild: dev: ghc: " <> Namespace.toPath namespace let outDir = root "_/bild/dev/bin" Dir.createDirectoryIfMissing True outDir putText <| "bild: dev: local: " <> Text.pack builder @@ -254,12 +244,12 @@ build target@Target {..} = do "--make", path, "-main-is", - nsToHaskellModule namespace, + Namespace.toHaskellModule namespace, "-o", outDir out ] Ghcjs -> do - putText <| "bild: dev: ghcjs: " <> nsToPath namespace + putText <| "bild: dev: ghcjs: " <> Namespace.toPath namespace let outDir = root "_/bild/dev/static" Dir.createDirectoryIfMissing True outDir putText <| "bild: dev: local: " <> Text.pack builder @@ -274,17 +264,17 @@ build target@Target {..} = do "--make", path, "-main-is", - nsToHaskellModule namespace, + Namespace.toHaskellModule namespace, "-o", outDir out ] Guile -> do - putText <| "bild: dev: guile: " <> nsToPath namespace + putText <| "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: " <> nsToPath namespace + putText <| "bild: nix: " <> Namespace.toPath namespace let outDir = root "_/bild/nix" Dir.createDirectoryIfMissing True outDir putText <| "bild: nix: remote: " <> Text.pack builder @@ -292,7 +282,7 @@ build target@Target {..} = do "nix-build" [ path, "-o", - outDir (Text.unpack <| nsToPath namespace), + outDir (Text.unpack <| Namespace.toPath namespace), -- Set default arguments to nix functions "--arg", "bild", @@ -310,42 +300,8 @@ build target@Target {..} = do builder ] -nsToHaskellModule :: Namespace -> String -nsToHaskellModule (Namespace parts Hs) = joinWith "." parts -nsToHaskellModule (Namespace _ ext) = - panic <| "can't convert " <> show ext <> " to a Haskell module" - -nsToPath :: Namespace -> Text -nsToPath (Namespace parts ext) = - Text.pack - <| joinWith "/" parts - <> "." - <> lowercase (show ext) - -metaNamespace :: Regex.RE Char Namespace -metaNamespace = Namespace ext - where - name = - Regex.many (Regex.psym Char.isUpper) - <> Regex.many (Regex.psym Char.isLower) - path = Regex.many (name <* Regex.string "/" <|> name) - ext = - Nix <$ Regex.string "nix" - <|> Hs <$ Regex.string "hs" - <|> Scm <$ Regex.string "scm" - 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 (/= ' ')) - --- | Replace 'a' in 's' with 'b'. -reps :: String -> String -> String -> String -reps a b s@(x : xs) = - if isPrefixOf a s - then -- then, write 'b' and replace jumping 'a' substring - b ++ reps a b (drop (length a) s) - else -- then, write 'x' char and try to replace tail string - x : reps a b xs -reps _ _ [] = [] diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs new file mode 100644 index 0000000..48ae1e6 --- /dev/null +++ b/Biz/Namespace.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Biz.Namespace + ( Namespace (..), + Ext (..), + fromPath, + toPath, + toHaskellModule, + match, + ) +where + +import Alpha +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Text.Regex.Applicative as Regex + +data Ext = Hs | Scm | Nix + deriving (Show) + +data Namespace = Namespace [String] Ext + deriving (Show) + +match :: String -> Maybe Namespace +match = Regex.match <| Namespace ext + where + name = + Regex.many (Regex.psym Char.isUpper) + <> Regex.many (Regex.psym Char.isLower) + path = Regex.many (name <* Regex.string "/" <|> name) + ext = + Nix <$ Regex.string "nix" + <|> Hs <$ Regex.string "hs" + <|> Scm <$ Regex.string "scm" + +fromPath :: String -> String -> Maybe Namespace +fromPath bizRoot absPath = + List.stripPrefix bizRoot absPath + >>= List.stripPrefix "/" + >>= match + +toHaskellModule :: Namespace -> String +toHaskellModule (Namespace parts Hs) = joinWith "." parts +toHaskellModule (Namespace _ ext) = + panic <| "can't convert " <> show ext <> " to a Haskell module" + +toPath :: Namespace -> Text +toPath (Namespace parts ext) = + Text.pack + <| joinWith "/" parts + <> "." + <> lowercase (show ext) -- cgit v1.2.3