Add Biz.Namespace library

3 files changed, 93 insertions, 61 deletions

diff --git a/Alpha.hs b/Alpha.hs
index 5d53f71..5ced72d 100644
--- a/Alpha.hs
+++ b/Alpha.hs
@@ -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)