@@ -3,7 +3,6 @@
33{-# LANGUAGE MultiParamTypeClasses #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TemplateHaskell #-}
76{-# LANGUAGE TupleSections #-}
87module Obelisk.Command.Run where
98
@@ -15,7 +14,7 @@ import Control.Monad.Reader (MonadIO)
1514import Data.Coerce (coerce)
1615import Data.Either
1716import Data.Foldable (for_)
18−import qualified Data.List as L
17+import Data.List.Extra (dropPrefix)
1918import qualified Data.List.NonEmpty as NE
2019import Data.Maybe
2120import qualified Data.Text as T
@@ -24,7 +23,6 @@ import Debug.Trace (trace)
2423import Distribution.Compiler (CompilerFlavor(..))
2524import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
2625import Distribution.Parsec.ParseResult (runParseResult)
27−import Distribution.Pretty
2826import qualified Distribution.System as Dist
2927import Distribution.Types.BuildInfo
3028import Distribution.Types.CondTree
@@ -38,13 +36,14 @@ import qualified Hpack.Yaml as Hpack
3836import Language.Haskell.Extension
3937import Network.Socket hiding (Debug)
4038import System.Directory
39+import System.Environment (getExecutablePath)
4140import System.FilePath
4241import qualified System.Info
4342import System.IO.Temp (withSystemTempDirectory)
4443
45−import Obelisk.App (MonadObelisk, ObeliskT)
46−import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
47−import Obelisk.Command.Project (inProjectShell, withProjectRoot)
44+import Obelisk.App (MonadObelisk)
45+import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
46+import Obelisk.Command.Project (inProjectShell, obeliskDirName, toObeliskDir, withProjectRoot)
4847import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
4948
5049data CabalPackageInfo = CabalPackageInfo
@@ -61,11 +60,12 @@ data CabalPackageInfo = CabalPackageInfo
6160 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
6261 }
6362
64−-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
65−run :: ObeliskT IO ()
63+-- | Used to signal to obelisk that it's being invoked as a preprocessor
64+preprocessorIdentifier :: String
65+preprocessorIdentifier = "__preprocessor-apply-packages"
66+
67+run :: MonadObelisk m => m ()
6668run = withProjectRoot "." $ \root -> do
67− let nixPath = $(staticWhich "nix")
68− nixBuildPath = $(staticWhich "nix-build")
6969 pkgs <- getLocalPkgs root
7070 withGhciScript pkgs $ \dotGhciPath -> do
7171 freePort <- getFreePort
@@ -124,20 +124,15 @@ runWatch = do
124124-- to the Nix @project@ function.
125125getLocalPkgs :: (MonadObelisk m, MonadIO m) => FilePath -> m [FilePath]
126126getLocalPkgs root = do
127− rootAbs <- liftIO $ makeAbsolute root
127+ (_exitCode, out, err) <- readCreateProcessWithExitCode $
128128 proc findExePath ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
129129 putLog Debug $ T.strip $ T.pack err
130130
131− let packagePaths = filter (not . isIgnored) $ T.lines $ T.strip $ T.pack out
132− obeliskImplDir = ".obelisk/impl/"
133− rootObelisk = T.pack (rootAbs </> T.unpack obeliskImplDir)
134− isIgnored path =
135− obeliskImplDir `T.isInfixOf` path
136− && case T.stripPrefix rootObelisk path of
137− Nothing -> True
138− Just pathSuffix -> obeliskImplDir `T.isInfixOf` pathSuffix
139−
140− pure $ map T.unpack packagePaths
131+ let
132+ -- We ignore any path that has ".obelisk" in it, but keep the root ".obelisk" paths
133+ packagePaths = filter (not . isIgnored) $ map T.unpack $ T.lines $ T.strip $ T.pack out
134+ isIgnored path = obeliskDirName `elem` dropPrefix (splitPath $ toObeliskDir root) (splitPath path)
135+ pure packagePaths
141136
142137data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
143138 deriving (Eq, Ord, Show)
@@ -255,15 +250,13 @@ withGhciScript dirs f = do
255250 unless (null pkgDirErrs) $
256251 putLog Warning $ T.pack $ "Failed to find packages in " <> intercalate ", " pkgDirErrs
257252
253+ selfExe <- liftIO getExecutablePath
258254 let
259255 packageNames = map _cabalPackageInfo_packageName packageInfos
260− languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
261− -- NOTE when no default-language is present cabal sets Haskell98
262− language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
263256 dotGhci = unlines
264− [ ":set -pgmF ob -optF apply-packages " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
257+ -- TODO: Shell escape
258+ [ ":set -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
265259 , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
266− , ":set " <> unwords (("-X" <>) . prettyShow <$> language)
267260 , ":load Backend Frontend"
268261 -- We need to also load 'Obelisk.Run' if it's part of our ghci session.
269262 <> if "obelisk-run" `elem` packageNames then " Obelisk.Run" else ""
@@ -271,7 +264,6 @@ withGhciScript dirs f = do
271264 , "import qualified Frontend"
272265 , "import qualified Backend"
273266 ]
274− warnDifferentLanguages language
275267 withSystemTempDirectory "ob-ghci" $ \fp -> do
276268 let dotGhciPath = fp </> ".ghci"
277269 liftIO $ writeFile dotGhciPath dotGhci
@@ -281,16 +273,15 @@ withGhciScript dirs f = do
281273 rootedSourceDirs pkg = NE.toList $
282274 (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
283275
284−warnDifferentLanguages :: MonadObelisk m => [Language] -> m ()
285−warnDifferentLanguages (_:_:_) = putLog Warning "Different languages detected across packages which may result in errors when loading the repl"
286−warnDifferentLanguages _ = return ()
287−
288276-- | Run ghci repl
289277runGhciRepl
290278 :: MonadObelisk m
291279 => FilePath -- ^ Path to .ghci
292280 -> m ()
293−runGhciRepl dotGhci = inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci
281+runGhciRepl dotGhci =
282+ -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
283+ -- ghc that is provided by the shell in the user's project.
284+ inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci
294285
295286-- | Run ghcid
296287runGhcid
@@ -298,7 +289,7 @@ runGhcid
298289 => FilePath -- ^ Path to .ghci
299290 -> Maybe String -- ^ Optional command to run at every reload
300291 -> m ()
301−runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
292+runGhcid dotGhci mcmd = inProjectShell "ghc" $ unwords $ ghcidExePath : opts -- TODO: Shell escape
302293 where
303294 opts =
304295 [ "-W"
@@ -307,7 +298,7 @@ runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
307298 , "--reload=config"
308299 , "--outputfile=ghcid-output.txt"
309300 ] <> testCmd
310− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
301+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
311302
312303makeBaseGhciOptions :: FilePath -> String
313304makeBaseGhciOptions dotGhci =