@@ -3,47 +3,58 @@
33{-# LANGUAGE MultiParamTypeClasses #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TemplateHaskell #-}
76{-# LANGUAGE TupleSections #-}
87module Obelisk.Command.Run where
98
10−import Control.Applicative (liftA2)
9+import Control.Arrow ((&&&))
1110import Control.Exception (Exception, bracket)
12−import Control.Monad
11+import Control.Monad (filterM, unless)
1312import Control.Monad.Except (runExceptT, throwError)
1413import Control.Monad.IO.Class (liftIO)
1514import Control.Monad.Reader (MonadIO)
15+import Data.Coerce (coerce)
1616import Data.Either
17−import Data.Foldable (for_)
18−import qualified Data.List as L
17+import Data.Foldable (for_, toList)
18+import Data.List.Extra (dropPrefix)
1919import qualified Data.List.NonEmpty as NE
20+import Data.Map (Map)
21+import qualified Data.Map as Map
2022import Data.Maybe
23+import qualified Data.Set as Set
24+import Data.Text (Text)
2125import qualified Data.Text as T
26+import Data.Traversable (for)
27+import Debug.Trace (trace)
2228import Distribution.Compiler (CompilerFlavor(..))
2329import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
2430import Distribution.Parsec.ParseResult (runParseResult)
25−import Distribution.Pretty
31+import qualified Distribution.System as Dist
2632import Distribution.Types.BuildInfo
2733import Distribution.Types.CondTree
2834import Distribution.Types.GenericPackageDescription
2935import Distribution.Types.Library
3036import Distribution.Utils.Generic
37+import qualified Distribution.Parsec.Common as Dist
3138import qualified Hpack.Config as Hpack
3239import qualified Hpack.Render as Hpack
3340import qualified Hpack.Yaml as Hpack
3441import Language.Haskell.Extension
3542import Network.Socket hiding (Debug)
3643import System.Directory
44+import System.Environment (getExecutablePath)
3745import System.FilePath
46+import qualified System.Info
3847import System.IO.Temp (withSystemTempDirectory)
39−import System.Which (staticWhich)
4048
41−import Obelisk.App (MonadObelisk, ObeliskT)
42−import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)
43−import Obelisk.Command.Project (inProjectShell, withProjectRoot)
49+import Obelisk.App (MonadObelisk)
50+import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
51+import Obelisk.Command.Project (obeliskDirName, toObeliskDir, withProjectRoot, nixShellWithPkgs, toNixPath)
52+import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
4453
4554data CabalPackageInfo = CabalPackageInfo
46− { _cabalPackageInfo_packageRoot :: FilePath
55+ { _cabalPackageInfo_packageFile :: FilePath
56+ , _cabalPackageInfo_packageName :: T.Text
57+ , _cabalPackageInfo_packageRoot :: FilePath
4758 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
4859 -- ^ List of hs src dirs of the library component
4960 , _cabalPackageInfo_defaultExtensions :: [Extension]
@@ -54,20 +65,19 @@ data CabalPackageInfo = CabalPackageInfo
5465 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
5566 }
5667
57−-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
58−run :: ObeliskT IO ()
59−run = do
60− let nixPath = $(staticWhich "nix")
61− nixBuildPath = $(staticWhich "nix-build")
62− pkgs <- getLocalPkgs
68+-- | Used to signal to obelisk that it's being invoked as a preprocessor
69+preprocessorIdentifier :: String
70+preprocessorIdentifier = "__preprocessor-apply-packages"
71+
72+run :: MonadObelisk m => m ()
73+run = withProjectRoot "." $ \root -> do
74+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
6375 withGhciScript pkgs $ \dotGhciPath -> do
6476 freePort <- getFreePort
65− assets <- withProjectRoot "." $ \root -> do
66− let importableRoot = if "/" `isInfixOf` root
67− then root
68− else "./" <> root
77+ assets <- do
78+ let importableRoot = toNixPath root
6979 isDerivation <- readProcessAndLogStderr Debug $
70− proc nixPath
80+ proc nixExePath
7181 [ "eval"
7282 , "-f"
7383 , root
@@ -79,83 +89,136 @@ run = do
7989 -- Check whether the impure static files are a derivation (and so must be built)
8090 if isDerivation == "1"
8191 then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option
82− proc nixBuildPath
92+ proc nixBuildExePath
8393 [ "--no-out-link"
8494 , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"
8595 ]
8696 else readProcessAndLogStderr Debug $
87− proc nixPath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
97+ proc nixExePath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
8898 putLog Debug $ "Assets impurely loaded from: " <> assets
89− runGhcid dotGhciPath $ Just $ unwords
99+ runGhcid dotGhciPath pkgs $ Just $ unwords
90100 [ "Obelisk.Run.run"
91101 , show freePort
92− , "(runServeAsset " ++ show assets ++ ")"
102+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
93103 , "Backend.backend"
94104 , "Frontend.frontend"
95105 ]
96106
97107runRepl :: MonadObelisk m => m ()
98108runRepl = do
99− pkgs <- getLocalPkgs
109+ pkgs <- fmap toList . parsePackagesOrFail =<< withProjectRoot "." getLocalPkgs
100110 withGhciScript pkgs $ \dotGhciPath -> do
101− runGhciRepl dotGhciPath
111+ runGhciRepl pkgs dotGhciPath
102112
103113runWatch :: MonadObelisk m => m ()
104114runWatch = do
105− pkgs <- getLocalPkgs
106− withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
115+ pkgs <- fmap toList . parsePackagesOrFail =<< withProjectRoot "." getLocalPkgs
116+ withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath pkgs Nothing
117+
118+-- | Relative paths to local packages of an obelisk project.
119+--
120+-- These are a combination of the obelisk predefined local packages,
121+-- and any packages that the user has set with the @packages@ argument
122+-- to the Nix @project@ function.
123+getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
124+getLocalPkgs root = do
125+ (_exitCode, out, err) <- readCreateProcessWithExitCode $
126+ proc findExePath ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
127+ putLog Debug $ T.strip $ T.pack err
128+
129+ let
130+ -- We ignore any path that has ".obelisk" in it, but keep the root ".obelisk" paths
131+ packagePaths = filter (not . isIgnored) $ map T.unpack $ T.lines $ T.strip $ T.pack out
132+ isIgnored path = obeliskDirName `elem` dropPrefix (splitPath $ toObeliskDir root) (splitPath path)
133+ pure packagePaths
107134
108135data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
109136 deriving (Eq, Ord, Show)
110137instance Exception GuessPackageFileError
111138
139+newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
140+newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
141+
112142-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
113143guessCabalPackageFile
114− :: MonadIO m
115− => FilePath -- ^ Directory to search for cabal package
116− -> m (Either GuessPackageFileError (Either FilePath FilePath))
117− -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.
118−guessCabalPackageFile dir = do
119− candidates <- liftIO $
120− filterM (doesFileExist . (dir </>))
121− =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))
122− <$> listDirectory dir
123− pure $ case L.partition (== Hpack.packageConfig) candidates of
124− ([hpack], _) -> Right $ Left hpack
125− ([], [cabal]) -> Right $ Right cabal
126− ([], []) -> Left GuessPackageFileError_NotFound
127− (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals
144+ :: (MonadIO m)
145+ => FilePath -- ^ Directory or path to search for cabal package
146+ -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
147+guessCabalPackageFile pkg = do
148+ liftIO (doesDirectoryExist pkg) >>= \case
149+ False -> case cabalOrHpackFile pkg of
150+ (Just hpack@(Right _)) -> pure $ Right hpack
151+ (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
152+ -- If the cabal file has a sibling hpack file, we use that instead
153+ -- since running hpack often generates a sibling cabal file
154+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
155+ hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
156+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
157+ Nothing -> pure $ Left GuessPackageFileError_NotFound
158+ True -> do
159+ candidates <- liftIO $
160+ filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
161+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
162+ pure $ case partitionEithers candidates of
163+ ([hpack], _) -> Right $ Left hpack
164+ ([], [cabal]) -> Right $ Right cabal
165+ ([], []) -> Left GuessPackageFileError_NotFound
166+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
128167
129−-- | Relative paths to local packages of an obelisk project
130−-- TODO a way to query this
131−getLocalPkgs :: Applicative f => f [FilePath]
132−getLocalPkgs = pure ["backend", "common", "frontend"]
168+cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
169+cabalOrHpackFile = \case
170+ x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
171+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
172+ | otherwise -> Nothing
133173
174+-- | Parses the cabal package in a given directory.
175+-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
134176parseCabalPackage
135− :: (MonadObelisk m)
136− => FilePath -- ^ package directory
177+ :: MonadObelisk m
178+ => FilePath -- ^ Package directory
137179 -> m (Maybe CabalPackageInfo)
138−parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do
139− (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case
140− Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir
141− Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir
142− Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)
143− Right (Left hpackFileName) -> do
180+parseCabalPackage dir = parseCabalPackage' dir >>= \case
181+ Left err -> Nothing <$ putLog Error err
182+ Right (warnings, pkgInfo) -> do
183+ for_ warnings $ putLog Warning . T.pack . show
184+ pure $ Just pkgInfo
185+
186+-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
187+parseCabalPackage'
188+ :: (MonadIO m)
189+ => FilePath -- ^ Package directory
190+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
191+parseCabalPackage' pkg = runExceptT $ do
192+ (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
193+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
194+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
195+ Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
196+ Right (Right (HPackFilePath file)) -> do
144197 let
145− file = dir </> hpackFileName
146198 decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
147199 liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
148200 Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
149− Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)
201+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
150202
151− let (warnings, result) = runParseResult $ parseGenericPackageDescription $
152− toUTF8BS cabalContents
153− for_ warnings $ putLog Warning . T.pack . show
203+ let
204+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
205+ osConfVar = case System.Info.os of
206+ "linux" -> Just Dist.Linux
207+ "darwin" -> Just Dist.OSX
208+ _ -> trace "Unrecgonized System.Info.os" Nothing
209+ archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
210+ evalConfVar v = Right $ case v of
211+ OS osVar -> Just osVar == osConfVar
212+ Arch archVar -> Just archVar == archConfVar
213+ Impl GHC _ -> True -- TODO: Actually check version range
214+ _ -> False
154215 case condLibrary <$> result of
155216 Right (Just condLib) -> do
156− let (_, lib) = simplifyCondTree (const $ pure True) condLib
157− pure $ CabalPackageInfo
158− { _cabalPackageInfo_packageRoot = dir
217+ let (_, lib) = simplifyCondTree evalConfVar condLib
218+ pure $ (warnings,) $ CabalPackageInfo
219+ { _cabalPackageInfo_packageName = T.pack packageName
220+ , _cabalPackageInfo_packageFile = packageFile
221+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile
159222 , _cabalPackageInfo_sourceDirs =
160223 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
161224 , _cabalPackageInfo_defaultExtensions =
@@ -168,45 +231,49 @@ parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< r
168231 Left (_, errors) ->
169232 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
170233
171−-- | Create ghci configuration to load the given packages
172−withGhciScript
173− :: MonadObelisk m
174− => [FilePath] -- ^ List of packages to load into ghci
175− -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
176− -> m ()
177−withGhciScript dirs f = do
178− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
234+parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
235+parsePackagesOrFail dirs = do
236+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
179237 flip fmap (parseCabalPackage dir) $ \case
180238 Nothing -> Left dir
181239 Just packageInfo -> Right packageInfo
182240
183− when (null packageInfos) $
184− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
241+ packageInfos <- case NE.nonEmpty packageInfos' of
242+ Nothing -> failWith $ T.pack $ "No valid packages found in " <> intercalate ", " dirs
243+ Just xs -> pure xs
244+
185245 unless (null pkgDirErrs) $
186− putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
246+ putLog Warning $ T.pack $ "Failed to find packages in " <> intercalate ", " pkgDirErrs
187247
188− let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
189− languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
190− -- NOTE when no default-language is present cabal sets Haskell98
191− language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
192− extensionsLine = if extensions == mempty
193− then ""
194− else ":set " <> unwords (("-X" <>) . prettyShow <$> extensions)
195− ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $
196− packageInfos >>= _cabalPackageInfo_compilerOptions
197− dotGhci = unlines
198− [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
199− , case ghcOptions of
200− [] -> ""
201− xs -> ":set " <> unwords xs
202− , extensionsLine
203− , ":set " <> unwords (("-X" <>) . prettyShow <$> language)
204− , ":load Backend Frontend"
205− , "import Obelisk.Run"
206− , "import qualified Frontend"
207− , "import qualified Backend"
208− ]
209− warnDifferentLanguages language
248+ pure packageInfos
249+
250+packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
251+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
252+
253+-- | Create ghci configuration to load the given packages
254+withGhciScript
255+ :: MonadObelisk m
256+ => [CabalPackageInfo] -- ^ List of packages to load into ghci
257+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
258+ -> m ()
259+withGhciScript packageInfos f = do
260+ selfExe <- liftIO getExecutablePath
261+ let
262+ packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
263+ modulesToLoad = mconcat
264+ [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
265+ , [ "Backend" | "backend" `Set.member` packageNames ]
266+ , [ "Frontend" | "frontend" `Set.member` packageNames ]
267+ ]
268+ dotGhci = unlines
269+ -- TODO: Shell escape
270+ [ ":set -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
271+ , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
272+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
273+ , "import qualified Obelisk.Run"
274+ , "import qualified Frontend"
275+ , "import qualified Backend"
276+ ]
210277 withSystemTempDirectory "ob-ghci" $ \fp -> do
211278 let dotGhciPath = fp </> ".ghci"
212279 liftIO $ writeFile dotGhciPath dotGhci
@@ -216,24 +283,26 @@ withGhciScript dirs f = do
216283 rootedSourceDirs pkg = NE.toList $
217284 (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
218285
219−warnDifferentLanguages :: MonadObelisk m => [Language] -> m ()
220−warnDifferentLanguages (_:_:_) = putLog Warning "Different languages detected across packages which may result in errors when loading the repl"
221−warnDifferentLanguages _ = return ()
222−
223286-- | Run ghci repl
224287runGhciRepl
225288 :: MonadObelisk m
226− => FilePath -- ^ Path to .ghci
289+ => [CabalPackageInfo]
290+ -> FilePath -- ^ Path to .ghci
227291 -> m ()
228−runGhciRepl dotGhci = inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci
292+runGhciRepl packages dotGhci = withProjectRoot "." $ \root ->
293+ -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
294+ -- ghc that is provided by the shell in the user's project.
295+ nixShellWithPkgs root True (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
229296
230297-- | Run ghcid
231298runGhcid
232299 :: MonadObelisk m
233300 => FilePath -- ^ Path to .ghci
301+ -> [CabalPackageInfo]
234302 -> Maybe String -- ^ Optional command to run at every reload
235303 -> m ()
236−runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
304+runGhcid dotGhci packages mcmd = withProjectRoot "." $ \root ->
305+ nixShellWithPkgs root True (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
237306 where
238307 opts =
239308 [ "-W"
@@ -242,7 +311,7 @@ runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
242311 , "--reload=config"
243312 , "--outputfile=ghcid-output.txt"
244313 ] <> testCmd
245− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
314+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
246315
247316makeBaseGhciOptions :: FilePath -> String
248317makeBaseGhciOptions dotGhci =