diff options
| -rw-r--r-- | Omni/Bild.hs | 65 |
1 files changed, 51 insertions, 14 deletions
diff --git a/Omni/Bild.hs b/Omni/Bild.hs index ba54c93..233b31c 100644 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -185,7 +185,7 @@ main = Cli.Plan help move test_ pure |> Cli.main test_bildBild :: Test.Tree test_bildBild = Test.unit "can bild bild" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute "Omni/Bild.hs" case Namespace.fromPath root path of Nothing -> Test.assertFailure "can't find ns for bild" @@ -201,7 +201,7 @@ test_bildBild = test_bildExamples :: Test.Tree test_bildExamples = Test.unit "can bild examples" <| do - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> ["c", "hs", "lisp", "rs"] |> map ("Omni/Bild/Example." <>) |> traverse Dir.makeAbsolute @@ -216,7 +216,7 @@ test_bildExamples = move :: Cli.Arguments -> IO () move args = do IO.hSetBuffering stdout IO.NoBuffering - root <- Env.getEnv "CODEROOT" + root <- getCoderoot loadGhcPkgCache namespaces <- Cli.getAllArgs args (Cli.argument "target") @@ -322,10 +322,10 @@ test_isGitHook = Test.group "isGitHook" [ Test.unit "filters pre-commit hook" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot True @=? (isGitHook <| root <> "/Omni/Ide/hooks/pre-commit"), Test.unit "doesn't filter non-hooks" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot False @=? (isGitHook <| root <> "/Omni/Bild.hs") ] @@ -458,7 +458,7 @@ data HsModuleGraph = HsModuleGraph -- | Use this to just get a target to play with at the repl. dev_getTarget :: FilePath -> IO Target dev_getTarget fp = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute fp Namespace.fromPath root path |> \case @@ -569,7 +569,7 @@ analyzeAll isPlanMode nss = do analyzeOne :: Namespace -> IO (Maybe Target) analyzeOne namespace@(Namespace parts ext) = do let path = Namespace.toPath namespace - root <- Env.getEnv "CODEROOT" + root <- getCoderoot let abspath = root </> path let quapath = path user <- Env.getEnv "USER" /> Text.pack @@ -834,7 +834,7 @@ analyzeAll isPlanMode nss = do detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath) detectHaskellImports _ contentLines = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot let initialMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ contentLines)) initialLocals <- toLocalFiles root initialMods let initialLocalsSet = Set.fromList initialLocals @@ -885,7 +885,7 @@ detectLispImports contentLines = -- 'detectHaskellImports'. detectPythonImports :: Analysis -> [Text] -> IO (Set FilePath) detectPythonImports _ contentLines = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot let initialMods = catMaybes (Regex.match pythonImport </ (Text.unpack </ contentLines)) initialLocals <- toLocalFiles root initialMods bfs root (Set.fromList initialLocals) Set.empty @@ -985,7 +985,7 @@ ghcPkgCacheHash = do ghcPkgCachePath :: IO (Maybe FilePath) ghcPkgCachePath = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot fmap (\h -> root </> vardir </> ("ghc-pkg-cache-" <> h <> ".json")) </ ghcPkgCacheHash loadGhcPkgCache :: IO () @@ -1042,7 +1042,7 @@ ghcPkgFindModule acc m = -- | Build module graph for Haskell targets, returns Nothing if TH or cycles detected buildHsModuleGraph :: Namespace -> FilePath -> Set FilePath -> IO (Maybe HsModuleGraph) buildHsModuleGraph namespace entryPoint deps = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot -- Analyze all dependencies first depNodes <- foldM (analyzeModule root) Map.empty (Set.toList deps) -- Then analyze the entry point itself @@ -1124,7 +1124,7 @@ isSuccess _ = False test :: Bool -> Target -> IO (Exit.ExitCode, ByteString) test loud Target {..} = - Env.getEnv "CODEROOT" + getCoderoot +> \root -> case compiler of Ghc -> Proc @@ -1153,7 +1153,7 @@ test loud Target {..} = build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode] build andTest loud jobs cpus analysis = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot let targets = Map.elems analysis let namespaces = map (\Target {..} -> namespace) targets -- Use adaptive concurrent UI unless --loud is set @@ -1345,7 +1345,7 @@ lispRequires = nixBuild :: Bool -> Int -> Int -> Target -> IO (Exit.ExitCode, ByteString) nixBuild loud maxJobs cores target@(Target {..}) = - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> instantiate root |> run +> \case (_, "") -> panic "instantiate did not produce a drv" (Exit.ExitSuccess, drv) -> @@ -1411,3 +1411,40 @@ nixBuild loud maxJobs cores target@(Target {..}) = onFailure = Log.fail ["bild", "symlink", nschunk namespace] >> Log.br, onSuccess = pure () } + +getCoderoot :: IO FilePath +getCoderoot = do + mEnvRoot <- Env.lookupEnv "CODEROOT" + cwd <- Dir.getCurrentDirectory + case mEnvRoot of + Just envRoot -> do + let isPrefix = envRoot `List.isPrefixOf` cwd + let validPrefix = isPrefix && ( + length envRoot == length cwd || + (length cwd > length envRoot && (List.!!) cwd (length envRoot) == '/') + ) + if validPrefix + then pure envRoot + else do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> pure envRoot + Nothing -> do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> panic "CODEROOT not set and could not find root" + +findRoot :: FilePath -> IO (Maybe FilePath) +findRoot dir = do + let marker = dir </> "Omni" + exists <- Dir.doesDirectoryExist marker + if exists + then pure (Just dir) + else do + let parent = takeDirectory dir + if parent == dir + then pure Nothing + else findRoot parent + |