diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Bild.hs | 322 | ||||
| -rw-r--r-- | Biz/Bild.nix | 104 | ||||
| -rw-r--r-- | Biz/Cli.hs | 1 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 27 | ||||
| -rw-r--r-- | Biz/Lint.hs | 2 | ||||
| -rw-r--r-- | Biz/Log.hs | 8 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 75 | ||||
| -rw-r--r-- | Biz/Pie.hs | 9 | ||||
| -rw-r--r-- | Biz/Pie.nix | 2 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 13 | ||||
| -rw-r--r-- | Biz/Que/Site.hs | 11 | ||||
| -rw-r--r-- | Biz/Test.hs | 3 |
12 files changed, 319 insertions, 258 deletions
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; } @@ -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 @@ -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" @@ -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, |