feat: implement t-1fKilH

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
+