From 0264f4a5dc37b16f872e6fa92bd8f1fc1e2b1826 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 23 Jul 2021 14:28:35 -0400
Subject: Automatically detect Haskell dependencies
This parses the files contents for imports, then uses ghc-pkg to lookup the
package that provides the module. Now I can do that analysis in Haskell instead
of nix, which is much easier to code with.
---
Biz/Bild.hs | 322 ++++++++++++++++++++++++++++++++++++-------------------
Biz/Bild.nix | 104 +++++++++---------
Biz/Cli.hs | 1 -
Biz/Devalloc.hs | 27 -----
Biz/Lint.hs | 2 -
Biz/Log.hs | 8 +-
Biz/Namespace.hs | 75 ++++++++-----
Biz/Pie.hs | 9 --
Biz/Pie.nix | 2 -
Biz/Que/Host.hs | 13 ---
Biz/Que/Site.hs | 11 --
Biz/Test.hs | 3 -
12 files changed, 319 insertions(+), 258 deletions(-)
delete mode 100644 Biz/Pie.nix
(limited to 'Biz')
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index ada7879..08fb208 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -1,19 +1,15 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | A general purpose build tool.
--
-- : out bild
--- : dep conduit
--- : dep conduit-extra
--- : dep docopt
--- : dep regex-applicative
--- : dep rainbow
--- : dep tasty
--- : dep tasty-hunit
--
-- == Design constraints
--
@@ -75,6 +71,7 @@
-- > bild -s <target>
--
-- Starts a repl/shell for target.
+--
-- - if target.hs, load ghci
-- - if target.scm, load scheme repl
-- - if target.clj, load a clojure repl
@@ -92,10 +89,14 @@
--
-- == Build Metadata
--
--- Metadata is set in the comments with a special syntax. For third-party deps,
+-- Metadata is set in the comments with a special syntax. For system-level deps,
-- we list the deps in comments in the target file, like:
--
--- > -- : dep aeson
+-- > -- : sys cmark
+--
+-- The name is used to lookup the package in `nixpkgs.pkgs.<name>`.
+-- Language-level deps can automatically determined by passing parsed import
+-- statements to a package database, eg `ghc-pkg find-module`.
--
-- The output executable is named with:
--
@@ -125,22 +126,28 @@ import Biz.Namespace (Namespace (..))
import qualified Biz.Namespace as Namespace
import qualified Biz.Test as Test
import qualified Control.Concurrent.Async as Async
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Char8 as Char8
+import qualified Data.ByteString.Lazy as ByteString
import qualified Data.Char as Char
import Data.Conduit ((.|))
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.Map as Map
import qualified Data.Maybe as Maybe
+import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as Text
+import qualified Data.Text.IO as Text.IO
import qualified System.Directory as Dir
import qualified System.Environment as Env
import qualified System.Exit as Exit
import System.FilePath (replaceExtension, (</>))
import qualified System.IO as IO
+import qualified System.Process as Process
import qualified Text.Regex.Applicative as Regex
-import qualified Prelude
main :: IO ()
main = Cli.main <| Cli.Plan help move test pure
@@ -149,8 +156,7 @@ main = Cli.main <| Cli.Plan help move test pure
Test.group
"Biz.Bild"
[ Test.unit "can bild bild" <| do
- let ns = Namespace ["Biz", "Bild"] Namespace.Hs
- analyze ns +> build False False +> \case
+ analyze "Biz/Bild.hs" /> Maybe.fromJust +> build False False +> \case
Exit.ExitFailure _ -> Test.assertFailure "can't bild bild"
_ -> pure ()
]
@@ -158,16 +164,28 @@ main = Cli.main <| Cli.Plan help move test pure
move :: Cli.Arguments -> IO ()
move args =
IO.hSetBuffering stdout IO.NoBuffering
- >> traverse getNamespace (Cli.getAllArgs args (Cli.argument "target"))
- /> catMaybes
- /> filter isBuildableNs
- +> traverse analyze
- +> traverse
- ( build
- (args `Cli.has` Cli.longOption "test")
- (args `Cli.has` Cli.longOption "loud")
- )
+ >> pure (Cli.getAllArgs args (Cli.argument "target"))
+ /> filter (not <. ("_" `List.isPrefixOf`))
+ +> filterM Dir.doesFileExist
+ +> traverse (\fn -> analyze fn /> (fn,))
+ /> filter (snd .> isJust)
+ /> Map.fromList
+ /> Map.map Maybe.fromJust
+ /> Map.filter (namespace .> isBuildableNs)
+ +> printOrBuild
+> exitSummary
+ where
+ printOrBuild :: Map FilePath Target -> IO [ExitCode]
+ printOrBuild analyses =
+ if args `Cli.has` Cli.longOption "analyze"
+ then Map.elems analyses |> putJSON >> pure [Exit.ExitSuccess]
+ else Map.toList analyses |> map snd |> traverse (build isTest isLoud)
+ isTest = args `Cli.has` Cli.longOption "test"
+ isLoud = args `Cli.has` Cli.longOption "loud"
+ putJSON = Aeson.encode .> ByteString.toStrict .> Char8.putStrLn
+
+nixStore :: String
+nixStore = "/nix/store/00000000000000000000000000000000-"
help :: Cli.Docopt
help =
@@ -179,9 +197,10 @@ Usage:
bild [options] <target>...
Options:
- --test Run tests on a target after building.
- --loud Show all output from compiler.
- --help Print this info
+ --test Run tests on a target after building
+ --loud Show all output from compiler
+ --analyze Only analyze and print as JSON, don't build
+ -h, --help Print this info
|]
exitSummary :: [Exit.ExitCode] -> IO ()
@@ -204,7 +223,7 @@ data Compiler
| Guile
| NixBuild
| Copy
- deriving (Show)
+ deriving (Show, Generic, Aeson.ToJSON)
data Target = Target
{ -- | Output name
@@ -213,14 +232,16 @@ data Target = Target
namespace :: Namespace,
-- | Absolute path to file
path :: FilePath,
- -- | Parsed/detected dependencies
- deps :: [Dep],
+ -- | Language-specific dependencies
+ langdeps :: Set Dep,
+ -- | System-level dependencies
+ sysdeps :: Set Dep,
-- | Which compiler should we use?
compiler :: Compiler,
-- | Where is this machine being built? Schema: user@location
builder :: Text
}
- deriving (Show)
+ deriving (Show, Generic, Aeson.ToJSON)
-- | We can't build everything yet...
isBuildableNs :: Namespace -> Bool
@@ -246,7 +267,7 @@ vardir = "_/var"
createHier :: String -> IO ()
createHier root =
- mapM_
+ traverse_
(Dir.createDirectoryIfMissing True)
[ root </> bindir,
root </> intdir,
@@ -254,74 +275,135 @@ createHier root =
root </> vardir
]
-getNamespace :: String -> IO (Maybe Namespace)
-getNamespace s = do
+-- >>> removeVersion "array-0.5.4.0-DFLKGIjfsadi"
+-- "array"
+removeVersion :: String -> String
+removeVersion = takeWhile (/= '.') .> butlast2
+ where
+ butlast2 s = take (length s - 2) s
+
+detectImports :: Namespace -> [Text] -> IO (Set Dep)
+detectImports (Namespace _ Namespace.Hs) contentLines = do
+ let imports =
+ contentLines
+ /> Text.unpack
+ /> Regex.match haskellImports
+ |> catMaybes
+ pkgs <- foldM ghcPkgFindModule Set.empty imports
+ transitivePkgs <-
+ imports
+ |> map (Namespace.fromHaskellModule .> Namespace.toPath)
+ |> traverse Dir.makeAbsolute
+ +> filterM Dir.doesFileExist
+ +> traverse analyze -- surely this is a bottleneck ripe for caching
+ /> catMaybes
+ /> map langdeps
+ /> mconcat
+ pure <| pkgs <> transitivePkgs
+detectImports _ _ = Exit.die "can only detectImports for Haskell"
+
+analyze :: FilePath -> IO (Maybe Target)
+analyze path = do
+ content <-
+ withFile path ReadMode <| \h ->
+ IO.hSetEncoding h IO.utf8_bom
+ >> Text.IO.hGetContents h
+ let contentLines = Text.lines content
root <- Env.getEnv "BIZ_ROOT"
- cwd <- Dir.getCurrentDirectory
- return <| Namespace.fromPath root <| cwd </> s
-
-analyze :: Namespace -> IO Target
-analyze namespace@(Namespace.Namespace _ ext) = do
- user <- Env.getEnv "USER" /> Text.pack
- 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
- return
- Target
- { deps = content /> Regex.match metaDep |> catMaybes,
- builder = user <> "@localhost",
- compiler = detectGhcCompiler out <| String.unlines content,
- ..
- }
- Namespace.Nix ->
- return
- Target
- { deps = [],
- compiler = NixBuild,
- out = Nothing,
- builder =
- if host == "lithium"
- then mempty
- else
- Text.concat
- [ "ssh://",
- user,
- "@dev.simatime.com?ssh-key=/home/",
- user,
- "/.ssh/id_rsa"
- ],
- ..
- }
- Namespace.Scm -> do
- content <- String.lines </ Prelude.readFile path
- return
- Target
- { deps = [],
- compiler = Guile,
- out =
- content
- /> Regex.match (metaOut ";;")
- |> catMaybes
- |> head,
- builder = user <> "@localhost",
- ..
- }
- _ ->
- return
- Target
- { deps = [],
- compiler = Copy,
- out = Nothing,
- builder = user <> "@localhost",
- ..
- }
+ absPath <- Dir.makeAbsolute path
+ Log.info ["bild", "analyze", str path]
+ let ns =
+ if "hs" `List.isSuffixOf` path
+ then Namespace.fromContent <| Text.unpack content
+ else Namespace.fromPath root absPath
+ case ns of
+ Nothing ->
+ Log.warn ["bild", "analyze", str path, "could not find namespace"]
+ >> Log.br
+ >> pure Nothing
+ Just namespace@(Namespace _ ext) ->
+ Just </ do
+ user <- Env.getEnv "USER" /> Text.pack
+ host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME"
+ case ext of
+ Namespace.Hs -> do
+ langdeps <- detectImports namespace contentLines
+ let out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut "--")
+ |> catMaybes
+ |> head
+ pure
+ Target
+ { builder = user <> "@localhost",
+ compiler = detectGhcCompiler out <| Text.unpack content,
+ sysdeps =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaSys "--")
+ |> catMaybes
+ |> Set.fromList,
+ ..
+ }
+ Namespace.Nix ->
+ pure
+ Target
+ { langdeps = Set.empty,
+ sysdeps = Set.empty,
+ compiler = NixBuild,
+ out = Nothing,
+ builder =
+ if host == "lithium"
+ then mempty
+ else
+ Text.concat
+ [ "ssh://",
+ user,
+ "@dev.simatime.com?ssh-key=/home/",
+ user,
+ "/.ssh/id_rsa"
+ ],
+ ..
+ }
+ Namespace.Scm -> do
+ pure
+ Target
+ { langdeps = Set.empty,
+ sysdeps = Set.empty,
+ compiler = Guile,
+ out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut ";;")
+ |> catMaybes
+ |> head,
+ builder = user <> "@localhost",
+ ..
+ }
+ _ ->
+ pure
+ Target
+ { langdeps = Set.empty,
+ sysdeps = Set.empty,
+ compiler = Copy,
+ out = Nothing,
+ builder = user <> "@localhost",
+ ..
+ }
+
+ghcPkgFindModule :: Set String -> String -> IO (Set String)
+ghcPkgFindModule acc m =
+ Process.readProcess
+ "ghc-pkg"
+ -- instead of relying on global deps declared in ./Bild/Deps/Haskell.nix, I
+ -- could fetch a global package-db from hackage API and pass it here with
+ -- --package-db=FILE
+ ["--names-only", "--simple-output", "find-module", m]
+ ""
+ /> String.lines
+ /> Set.fromList
+ /> Set.union acc
-- | 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,
@@ -332,7 +414,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do
-- import list.
detectGhcCompiler :: Maybe Out -> String -> Compiler
detectGhcCompiler (Just out) _ | jsSuffix out = GhcjsExe
-detectGhcCompiler (Just out) _ | not <| jsSuffix out = GhcExe
+detectGhcCompiler (Just _) _ = GhcExe
detectGhcCompiler Nothing content
| match "import GHCJS" = GhcjsLib
| otherwise = GhcLib
@@ -386,7 +468,7 @@ build andTest loud Target {..} = do
onFailure = Log.fail ["test", nschunk namespace] >> Log.br,
onSuccess = Log.pass ["test", nschunk namespace] >> Log.br
}
- else return exitcode
+ else pure exitcode
GhcLib -> do
Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
proc
@@ -440,16 +522,17 @@ build andTest loud Target {..} = do
-- ]
Guile -> do
Log.info ["bild", "dev", "guile", nschunk namespace]
- proc
- loud
- namespace
- "guild"
- [ "compile",
- "--r7rs",
- "--load-path=" ++ root,
- "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
- path
- ]
+ _ <-
+ proc
+ loud
+ namespace
+ "guild"
+ [ "compile",
+ "--r7rs",
+ "--load-path=" ++ root,
+ "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
+ path
+ ]
when (isJust out) <| do
let o = Maybe.fromJust out
writeFile
@@ -467,7 +550,7 @@ build andTest loud Target {..} = do
]
p <- Dir.getPermissions <| root </> bindir </> o
Dir.setPermissions (root </> bindir </> o) (Dir.setOwnerExecutable True p)
- return Exit.ExitSuccess
+ pure Exit.ExitSuccess
NixBuild -> do
Log.info
[ "bild",
@@ -489,7 +572,7 @@ build andTest loud Target {..} = do
]
Copy -> do
Log.warn ["bild", "copy", "TODO", nschunk namespace]
- return Exit.ExitSuccess
+ pure Exit.ExitSuccess
data Proc = Proc
{ loud :: Bool,
@@ -515,8 +598,8 @@ run Proc {..} = do
<| Async.Concurrently
<| Conduit.waitForStreamingProcess cph
if isFailure exitcode
- then puts stderr_ >> onFailure >> return exitcode
- else onSuccess >> return exitcode
+ then puts stderr_ >> onFailure >> pure exitcode
+ else onSuccess >> pure exitcode
-- | Helper for running a standard bild subprocess.
proc :: Bool -> Namespace -> String -> [String] -> IO Exit.ExitCode
@@ -541,5 +624,20 @@ nschunk = Namespace.toPath .> Text.pack
metaDep :: Regex.RE Char Dep
metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
+metaSys :: [Char] -> Regex.RE Char Dep
+metaSys comment = Regex.string (comment ++ " : sys ") *> Regex.many (Regex.psym Char.isAlpha)
+
metaOut :: [Char] -> Regex.RE Char Out
metaOut comment = Regex.string (comment ++ " : out ") *> Regex.many (Regex.psym (/= ' '))
+
+haskellImports :: Regex.RE Char String
+haskellImports =
+ Regex.string "import"
+ *> Regex.some (Regex.psym Char.isSpace)
+ *> Regex.many (Regex.psym Char.isLower)
+ *> Regex.many (Regex.psym Char.isSpace)
+ *> Regex.some (Regex.psym isModuleChar)
+ <* Regex.many Regex.anySym
+ where
+ isModuleChar c =
+ elem c <| concat [['A' .. 'Z'], ['a' .. 'z'], ['.', '_'], ['0' .. '9']]
diff --git a/Biz/Bild.nix b/Biz/Bild.nix
index a3584ae..3cd5026 100644
--- a/Biz/Bild.nix
+++ b/Biz/Bild.nix
@@ -2,85 +2,97 @@
let
- inherit (nixpkgs) lib stdenv;
ghcCompiler = "ghc884";
ghcjsCompiler = "ghcjs86";
# provided by .envrc
root = builtins.getEnv "BIZ_ROOT";
- # general functions to put in a lib
- lines = s: lib.pipe s [
- (builtins.split "\n")
- (builtins.filter (x: builtins.typeOf x == "string"))
- ];
- removeNull = ls: builtins.filter (x: x != null) ls;
-
selectAttrs = deps: packageSet:
- lib.attrsets.attrVals deps packageSet;
+ nixpkgs.lib.attrsets.attrVals deps packageSet;
# returns true if a is a subset of b, where a and b are attrsets
subset = a: b: builtins.all
(x: builtins.elem x b) a;
+ # 44 = lib.strings.stringLength "/nix/store/gia2r9mxhc900y1m97dlmr1g3rm3ich3-"
+ dropNixStore = s: nixpkgs.lib.strings.substring 44 (nixpkgs.lib.strings.stringLength s) s;
+
haskellDeps = hpkgs: import ./Bild/Deps/Haskell.nix hpkgs;
mkGhcPackageSet = nixpkgs.haskell.packages.${ghcCompiler}.ghcWithHoogle;
#mkGhcjsPackageSet = nixpkgs.haskell.packages.${ghcjsCompiler}.ghcWithPackages;
in rec {
- # gather data needed for compiling by analyzing the main module
- analyze = main: rec {
- # path to the module relative to the git root
- relpath = builtins.replaceStrings ["${root}/"] [""]
- (builtins.toString main);
- # Haskell-appropriate name of the module
- module = builtins.replaceStrings ["/" ".hs"] ["." ""] relpath;
- # file contents
- content = builtins.readFile main;
- # search for the ': out' declaration
- out = lib.pipe content [
- lines
- (map (builtins.match "^-- : out ([[:alnum:]._-]*)$"))
- removeNull
- lib.lists.flatten
- builtins.head
- ];
- # collect all of the ': dep' declarations
- deps = lib.pipe content [
- lines
- (map (builtins.match "^-- : dep ([[:alnum:]._-]*)$"))
- removeNull
- lib.lists.flatten
- ];
- # collect ': sys' declarations
- sysdeps = lib.pipe content [
- lines
- (map (builtins.match "^-- : sys ([[:alnum:]._-]*)$"))
- removeNull
- lib.lists.flatten
- ];
+ inherit (nixpkgs) lib stdenv pkgs sources;
+
+ # a standard nix build for `bild` - this should be the only hand-written
+ # builder we need
+ bild = stdenv.mkDerivation {
+ name = "bild";
+ src = ../.;
+ nativeBuildInputs = [ ghcPackageSetFull ];
+ buildInputs = [ ghcPackageSetFull nixpkgs.makeWrapper ];
+ propagatedBuildInputs = [ ghcPackageSetFull ];
+ strictDeps = true;
+ buildPhase = ''
+ mkdir -p $out/bin
+ ghc \
+ -Werror \
+ -i. \
+ --make Biz/Bild.hs \
+ -main-is Biz.Bild \
+ -o $out/bin/bild
+ '';
+ installPhase = ''
+ wrapProgram $out/bin/bild --prefix PATH : ${lib.makeBinPath [ ghcPackageSetFull ]}
+ '';
};
+ # wrapper around bild
+ runBildAnalyze = main: stdenv.mkDerivation {
+ name = "bild-analysis";
+ src = ../.;
+ USER = "nixbld";
+ HOSTNAME = "nix-sandbox";
+ BIZ_ROOT = "$src";
+ buildPhase = ''
+ set -eux
+ mkdir $out
+ : analyzing with bild
+ ${bild}/bin/bild --analyze ${main} 1> $out/analysis.json 2> $out/stderr
+ set +eux
+ '';
+ installPhase = "exit 0";
+ };
+
+ # gather data needed for compiling by analyzing the main module
+ analyze = main:
+ builtins.head
+ (lib.trivial.importJSON
+ (runBildAnalyze main + "/analysis.json"));
+
ghcPackageSetFull = mkGhcPackageSet haskellDeps;
ghc = main:
let
data = analyze main;
- ghc = mkGhcPackageSet (hp: selectAttrs data.deps hp);
+ ghc = mkGhcPackageSet (hp: selectAttrs data.langdeps hp);
+ module = lib.strings.concatStringsSep "." data.namespace.path;
in stdenv.mkDerivation {
- name = data.module;
+ name = module;
src = ../.;
nativeBuildInputs = [ ghc ] ++ selectAttrs data.sysdeps nixpkgs.pkgs;
strictDeps = true;
buildPhase = ''
+ set -eux
mkdir -p $out/bin
- # compile with ghc
+ : compiling with ghc
${ghc}/bin/ghc \
-Werror \
-i. \
--make ${main} \
- -main-is ${data.module} \
+ -main-is ${module} \
-o $out/bin/${data.out}
'';
# the install process was handled above
@@ -162,8 +174,4 @@ in rec {
};
os = cfg: (nixpkgs.nixos (args: cfg)).toplevel;
-
- sources = nixpkgs.sources;
-
- pkgs = nixpkgs.pkgs;
}
diff --git a/Biz/Cli.hs b/Biz/Cli.hs
index 0054e26..435ded2 100644
--- a/Biz/Cli.hs
+++ b/Biz/Cli.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
--- : dep docopt
module Biz.Cli
( Plan (..),
main,
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 9eea33d..b30bac4 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -23,34 +23,7 @@
-- Developer allocation
--
-- : out devalloc
--- : dep acid-state
--- : dep clay
--- : dep cmark
-- : sys cmark
--- : dep cmark-lucid
--- : dep docopt
--- : dep envy
--- : dep github
--- : dep http-api-data
--- : dep ixset
--- : dep lucid
--- : dep neat-interpolation
--- : dep protolude
--- : dep rainbow
--- : dep req
--- : dep safecopy
--- : dep servant
--- : dep servant-auth
--- : dep servant-auth-server
--- : dep servant-lucid
--- : dep servant-server
--- : dep tasty
--- : dep tasty-hunit
--- : dep tasty-quickcheck
--- : dep uuid
--- : dep vector
--- : dep vector-algorithms
--- : dep warp
module Biz.Devalloc
( main,
test,
diff --git a/Biz/Lint.hs b/Biz/Lint.hs
index 3039b72..38c7403 100644
--- a/Biz/Lint.hs
+++ b/Biz/Lint.hs
@@ -5,8 +5,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- : out lint
--- : dep rainbow
--- : dep regex-applicative
module Biz.Lint (main) where
import Alpha
diff --git a/Biz/Log.hs b/Biz/Log.hs
index 9a790aa..747efed 100644
--- a/Biz/Log.hs
+++ b/Biz/Log.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
--- : dep rainbow
module Biz.Log
( Lvl (..),
good,
@@ -44,7 +43,7 @@ msg lvl labels =
-- systemd doesn't render msgs produced by putChunk, so when live we don't
-- use rainbow at all
"Live" -> putStr txt
- _ -> Rainbow.putChunk <| fore color <| clear <> chunk txt <> "\r"
+ _ -> Rainbow.hPutChunks IO.stderr [fore color <| clear <> chunk txt <> "\r"]
where
txt = Text.intercalate gap (label : labels)
(color, label) = case lvl of
@@ -60,7 +59,7 @@ gap :: Text
gap = ": "
br :: IO ()
-br = Rainbow.putChunk "\n" >> IO.hFlush stdout
+br = Rainbow.hPutChunks stderr ["\n"] >> IO.hFlush stderr
good, pass, info, warn, fail :: [Text] -> IO ()
good = msg Good
@@ -74,12 +73,13 @@ mark :: Show a => Text -> a -> a
mark label val =
unsafePerformIO <| do
msg Mark [label, tshow val]
+ br
pure val
-- | Pipelined version of 'mark'.
--
-- @
--- mark label val = val ~| label
+-- mark label val = val ~& label
-- @
(~&) :: Show a => a -> Text -> a
(~&) val label = mark label val
diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs
index 316896a..c3252fd 100644
--- a/Biz/Namespace.hs
+++ b/Biz/Namespace.hs
@@ -1,58 +1,58 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
--- : dep regex-applicative
module Biz.Namespace
( Namespace (..),
Ext (..),
fromPath,
+ fromContent,
+ fromHaskellModule,
toPath,
toHaskellModule,
toSchemeModule,
- match,
)
where
import Alpha
+import qualified Data.Aeson as Aeson
import qualified Data.Char as Char
import qualified Data.List as List
+import qualified Data.List.Split as List
import qualified Text.Regex.Applicative as Regex
data Ext = Hs | Scm | Nix | Md | Css | Py | Sh | Keys | Json | None
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic, Aeson.ToJSON)
-data Namespace = Namespace [String] Ext
- deriving (Eq, 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.isAlphaNum)
- path = Regex.many (name <* Regex.string "/" <|> name)
- ext =
- Nix <$ Regex.string "nix"
- <|> Hs <$ Regex.string "hs"
- <|> Scm <$ Regex.string "scm"
- <|> Md <$ Regex.string "md"
- <|> Css <$ Regex.string "css"
- <|> Py <$ Regex.string "py"
- <|> Sh <$ Regex.string "sh"
- <|> Keys <$ Regex.string "pub"
- <|> Json <$ Regex.string "json"
+data Namespace = Namespace {path :: [String], ext :: Ext}
+ deriving (Eq, Show, Generic, Aeson.ToJSON)
fromPath :: String -> String -> Maybe Namespace
fromPath bizRoot absPath =
List.stripPrefix bizRoot absPath
+> List.stripPrefix "/"
- +> match
+ +> Regex.match (Namespace </ rePath <* dot <*> reExt)
+
+fromContent :: String -> Maybe Namespace
+fromContent c = case Regex.findFirstInfix haskellModule c of
+ Nothing -> Nothing
+ Just (_, Namespace {..}, _) -> Just <| Namespace (filter (/= ".") path) ext
+ where
+ haskellModule =
+ Namespace
+ </ (Regex.string "\nmodule " *> Regex.many (name <|> dot))
+ <*> pure Hs
toHaskellModule :: Namespace -> String
toHaskellModule (Namespace parts Hs) = joinWith "." parts
-toHaskellModule (Namespace _ ext) =
+toHaskellModule (Namespace {..}) =
panic <| "can't convert " <> show ext <> " to a Haskell module"
+fromHaskellModule :: String -> Namespace
+fromHaskellModule s = Namespace (List.splitOn "." s) Hs
+
toPath :: Namespace -> FilePath
toPath (Namespace parts ext) =
joinWith "/" parts
@@ -61,5 +61,28 @@ toPath (Namespace parts ext) =
toSchemeModule :: Namespace -> String
toSchemeModule (Namespace parts Scm) = "(" ++ joinWith " " parts ++ ")"
-toSchemeModule (Namespace _ ext) =
+toSchemeModule (Namespace {..}) =
panic <| "can't convert " <> show ext <> " to a Scheme module"
+
+dot :: Regex.RE Char String
+dot = Regex.some <| Regex.sym '.'
+
+name :: Regex.RE Char String
+name =
+ Regex.many (Regex.psym Char.isUpper)
+ <> Regex.many (Regex.psym Char.isAlphaNum)
+
+rePath :: Regex.RE Char [String]
+rePath = Regex.many (name <* Regex.string "/" <|> name)
+
+reExt :: Regex.RE Char Ext
+reExt =
+ Nix <$ Regex.string "nix"
+ <|> Hs <$ Regex.string "hs"
+ <|> Scm <$ Regex.string "scm"
+ <|> Md <$ Regex.string "md"
+ <|> Css <$ Regex.string "css"
+ <|> Py <$ Regex.string "py"
+ <|> Sh <$ Regex.string "sh"
+ <|> Keys <$ Regex.string "pub"
+ <|> Json <$ Regex.string "json"
diff --git a/Biz/Pie.hs b/Biz/Pie.hs
index 15e5949..ff02716 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -34,15 +34,6 @@
-- Bild Metadata:
--
-- : out pie
--- : dep aeson
--- : dep docopt
--- : dep haskeline
--- : dep protolude
--- : dep parsec
--- : dep rainbow
--- : dep tasty
--- : dep tasty-hunit
--- : dep tasty-quickcheck
module Biz.Pie
( main,
)
diff --git a/Biz/Pie.nix b/Biz/Pie.nix
deleted file mode 100644
index b519995..0000000
--- a/Biz/Pie.nix
+++ /dev/null
@@ -1,2 +0,0 @@
-{ bild ? import ./Bild.nix {} }:
-bild.ghc ./Pie.hs
diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index fda9835..40ee1a5 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -13,19 +13,6 @@
-- - sorta: <https://ngrok.com/> and <https://localtunnel.github.io/www/>
--
-- : out que-server
---
--- : dep async
--- : dep docopt
--- : dep envy
--- : dep protolude
--- : dep rainbow
--- : dep scotty
--- : dep stm
--- : dep tasty
--- : dep tasty-hunit
--- : dep tasty-quickcheck
--- : dep unagi-chan
--- : dep unordered-containers
module Biz.Que.Host
( main,
)
diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs
index 43441df..06b86c8 100644
--- a/Biz/Que/Site.hs
+++ b/Biz/Que/Site.hs
@@ -7,17 +7,6 @@
-- | spawns a few processes that serve the que.run website
--
-- : out que-website
---
--- : dep async
--- : dep docopt
--- : dep config-ini
--- : dep process
--- : dep protolude
--- : dep rainbow
--- : dep req
--- : dep tasty
--- : dep tasty-hunit
--- : dep tasty-quickcheck
module Biz.Que.Site
( main,
)
diff --git a/Biz/Test.hs b/Biz/Test.hs
index fefa85d..bd1384e 100644
--- a/Biz/Test.hs
+++ b/Biz/Test.hs
@@ -1,8 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
--- : dep tasty
--- : dep tasty-hunit
--- : dep tasty-quickcheck
module Biz.Test
( Tree,
run,
--
cgit v1.2.3