diff options
| -rw-r--r-- | Alpha.hs | 26 | ||||
| -rw-r--r-- | Biz/Bild.hs | 74 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 54 |
3 files changed, 93 insertions, 61 deletions
@@ -22,6 +22,10 @@ module Alpha module X, String, + -- * Composing + compose, + (.>), + -- * Applying (<|), (|>), @@ -64,6 +68,22 @@ import Protolude as X hiding (($), (&)) say :: Text -> IO () say = putText +-- | Composition +compose :: (a -> b) -> (b -> c) -> (a -> c) +compose f g x = g (f x) + +-- | Right-composition operator +infixl 9 .> + +(.>) :: (a -> b) -> (b -> c) -> (a -> c) +f .> g = compose f g + +-- | Left-composition operator +infixr 9 <. + +(<.) :: (b -> c) -> (a -> b) -> (a -> c) +g <. f = compose f g + -- | Alias for map, fmap, <$> (</) :: Functor f => (a -> b) -> f a -> f b f </ g = fmap f g @@ -76,13 +96,15 @@ f </ g = fmap f g -- | Normal function application. Do the right side, then pass the -- return value to the function on the left side. +infixr 0 <| + (<|) :: (a -> b) -> a -> b f <| g = f g -infixr 0 <| - -- | Reverse function application. Do the left side, then pass the -- return value to the function on the right side. +infixl 0 |> + (|>) :: a -> (a -> b) -> b f |> g = g f 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 </ readFile "/etc/hostname" cwd <- Dir.getCurrentDirectory let path = cwd </> 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 </ Prelude.readFile path let out = content /> 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 </ path <* Regex.sym '.' <*> 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 </ path <* Regex.sym '.' <*> 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) |