@@ -1,94 +1,554 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
17{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE QuasiQuotes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE ViewPatterns #-}
212module Obelisk.Command.Run where
313
4−import qualified Control.Exception as E
5−import Control.Monad
6−import Data.Either
7−import Data.List
8−import Data.Maybe
9−import Data.Monoid
10−import Data.List.NonEmpty as NE
11−import Distribution.Utils.Generic (withUTF8FileContents)
12−import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))
13−import Distribution.Types.BuildInfo
14−import Distribution.Types.CondTree
15−import Distribution.Types.Library
16−import Distribution.Types.GenericPackageDescription
17−import Network.Socket
14+import Control.Arrow ((&&&))
15+import Control.Exception (Exception, bracket)
16+import Control.Lens (ifor, (.~), (&))
17+import Control.Monad (filterM)
18+import Control.Monad.Except (runExceptT, throwError)
19+import Control.Monad.IO.Class (liftIO)
20+import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
23+import Data.Coerce (coerce)
24+import Data.Default (def)
25+import Data.Either (partitionEithers)
26+import Data.Foldable (fold, for_, toList)
27+import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
29+import Data.List.NonEmpty (NonEmpty)
30+import qualified Data.List.NonEmpty as NE
31+import Data.Map (Map)
32+import qualified Data.Map as Map
33+import qualified Data.Map.Monoidal as MMap
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
36+import Data.Set (Set)
37+import qualified Data.Set as Set
38+import Data.String.Here.Interpolated (i)
39+import Data.Text (Text)
40+import qualified Data.Text as T
41+import Data.Time.Clock (getCurrentTime)
42+import Data.Time.Format (formatTime, defaultTimeLocale)
43+import Data.Traversable (for)
44+import Debug.Trace (trace)
45+import Distribution.Compiler (CompilerFlavor(..))
46+import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
47+import Distribution.Parsec.ParseResult (runParseResult)
48+import qualified Distribution.System as Dist
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
50+import Distribution.Types.CondTree (simplifyCondTree)
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
52+import Distribution.Types.Library (libBuildInfo)
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
54+import qualified Distribution.Parsec.Common as Dist
55+import qualified Hpack.Config as Hpack
56+import qualified Hpack.Render as Hpack
57+import qualified Hpack.Yaml as Hpack
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
1860import System.Directory
61+import System.Environment (getExecutablePath)
1962import System.FilePath
63+import qualified System.Info
2064import System.IO.Temp (withSystemTempDirectory)
21−import System.Process (callCommand)
2265
23−run :: IO ()
24−run = do
66+import Obelisk.App (MonadObelisk)
67+import Obelisk.CliApp (
68+ Severity (..),
69+ failWith,
70+ proc,
71+ putLog,
72+ readCreateProcessWithExitCode,
73+ readProcessAndLogStderr,
74+ runProcess_,
75+ setCwd,
76+ setDelegateCtlc,
77+ withSpinner,
78+ )
79+import Obelisk.Command.Nix
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
81+import Obelisk.Command.Thunk (attrCacheFileName)
82+import Obelisk.Command.Utils (findExePath, ghcidExePath)
83+
84+data CabalPackageInfo = CabalPackageInfo
85+ { _cabalPackageInfo_packageFile :: FilePath
86+ , _cabalPackageInfo_packageName :: T.Text
87+ , _cabalPackageInfo_packageRoot :: FilePath
88+ , _cabalPackageInfo_buildable :: Bool
89+ , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
90+ -- ^ List of hs src dirs of the library component
91+ , _cabalPackageInfo_defaultExtensions :: [Extension]
92+ -- ^ List of globally enable extensions of the library component
93+ , _cabalPackageInfo_defaultLanguage :: Maybe Language
94+ -- ^ List of globally set languages of the library component
95+ , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
96+ -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
97+ , _cabalPackageInfo_cppOptions :: [String]
98+ -- ^ List of CPP (C Preprocessor) options (e.g. the "cpp-options" field of the cabal file)
99+ }
100+
101+-- | 'Bool' with a better name for its purpose.
102+data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
103+
104+textInterpret :: Interpret -> Text
105+textInterpret = \case
106+ Interpret_Interpret -> "Interpret"
107+ Interpret_NoInterpret -> "NoInterpret"
108+
109+-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
110+data PathTree a = PathTree_Node
111+ (Maybe a) -- An optional leaf at this point in the tree
112+ (Map FilePath (PathTree a)) -- Branches to deeper leaves
113+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
114+
115+-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116+drawPathTree :: (a -> Text) -> PathTree a -> Text
117+drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
118+ where
119+ annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
120+ goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
121+ goForest [] = []
122+ goForest [tree] = shift "└─ " " " (goTree tree)
123+ goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
124+ shift first other = zipWith (<>) (first : repeat other)
125+
126+-- | Used to signal to obelisk that it's being invoked as a preprocessor
127+preprocessorIdentifier :: String
128+preprocessorIdentifier = "__preprocessor-apply-packages"
129+
130+profile
131+ :: MonadObelisk m
132+ => String
133+ -> [String]
134+ -> m ()
135+profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
136+ putLog Debug "Using profiled build of project."
137+
138+ outPath <- withSpinner "Building profiled executable" $
139+ fmap (T.unpack . T.strip) $ readProcessAndLogStderr Debug $ setCwd (Just root) $ nixCmdProc $
140+ NixCmd_Build $ def
141+ & nixBuildConfig_outLink .~ OutLink_None
142+ & nixCmdConfig_target .~ Target
143+ { _target_path = Just "."
144+ , _target_attr = Just "__unstable__.profiledObRun"
145+ , _target_expr = Nothing
146+ }
147+ assets <- findProjectAssets root
148+ putLog Debug $ "Assets impurely loaded from: " <> assets
149+ time <- liftIO getCurrentTime
150+ let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
151+ liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152+ putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153+ freePort <- getFreePort
154+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155+ [ show freePort
156+ , T.unpack assets
157+ , profileBaseName
158+ , "+RTS"
159+ , "-po" <> profileBaseName
160+ ] <> rtsFlags
161+ <> [ "-RTS" ]
162+
163+run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164+run root interpretPaths = do
165+ pkgs <- getParsedLocalPkgs root interpretPaths
166+ assets <- findProjectAssets root
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ ghciArgs <- getGhciSessionSettings pkgs root True
25169 freePort <- getFreePort
26− pkgs <- getLocalPkgs
27− (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
28− let cabalFp = pkg </> pkg <.> "cabal"
29− xs <- parseHsSrcDir cabalFp
30− return $ case xs of
31− Nothing -> Left pkg
32− Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs
33− when (null hsSrcDirs) $
34− fail $ "No valid pkgs found in " <> intercalate ", " pkgs
35− when (not (null pkgDirErrs)) $
36− putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
37− let dotGhci = unlines
38− [ ":set args --quiet --port " <> show freePort
39− , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)
40− , ":set -XScopedTypeVariables"
41− , ":add Backend Frontend"
42− , ":module + System.IO Control.Exception Control.Concurrent Obelisk.Widget.Run Frontend Backend"
43− ]
44− testCmd = unlines
45− [ "let handleBackendErr (_ :: SomeException) = hPutStrLn stderr \"backend stopped; make a change to your code to reload\""
46− , "backendTid <- forkIO $ handle handleBackendErr backend"
47− , "let conf = defRunConfig { _runConfig_redirectPort = " <> show freePort <> "}"
48− , "runWidget conf frontend"
49− , "killThread backendTid"
50− ]
170+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
172+ [ "Obelisk.Run.run"
173+ , show freePort
174+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
175+ , "Backend.backend"
176+ , "Frontend.frontend"
177+ ]
178+
179+runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180+runRepl root interpretPaths = do
181+ pkgs <- getParsedLocalPkgs root interpretPaths
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
185+
186+runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187+runWatch root interpretPaths = do
188+ pkgs <- getParsedLocalPkgs root interpretPaths
189+ ghciArgs <- getGhciSessionSettings pkgs root True
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
192+
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194+exportGhciConfig useRelativePaths root interpretPaths = do
195+ pkgs <- getParsedLocalPkgs root interpretPaths
196+ getGhciSessionSettings pkgs "." useRelativePaths
197+
198+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
199+nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200+ pkgs <- getParsedLocalPkgs root interpretPaths
201+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
202+
203+-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
204+getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
205+getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
206+
207+-- | Relative paths to local packages of an obelisk project.
208+--
209+-- These are a combination of the obelisk predefined local packages,
210+-- and any packages that the user has set with the @packages@ argument
211+-- to the Nix @project@ function.
212+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
213+getLocalPkgs root interpretPaths = do
214+ putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
215+ obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
216+
217+ -- We do not want to find packages that are embedded inside other obelisk projects, unless that
218+ -- obelisk project is our own.
219+ obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
220+ filter (/= root) $ map takeDirectory obeliskPackagePaths
221+ putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
222+ let rootsAndExclusions = calcIntepretFinds "" interpretPaths
223+
224+ fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
225+ let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
226+ in fmap (Set.fromList . map normalise) $ runFind $
227+ ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
228+ <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
229+ where
230+ runFind args = do
231+ (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
232+ putLog Debug $ T.strip $ T.pack err
233+ pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
234+
235+-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
236+-- This is used when constructing a set of @find@ commands to run to produce a set of packages
237+-- that matches the user's @--interpret@/@--no-interpret@ settings.
238+calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
239+calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
240+ where
241+ go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
242+ exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
243+ pure $ Map.singleton parent' children'
244+ deeperFinds <- Map.traverseWithKey go exclusions
245+ pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
246+
247+-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
248+foldPathTreeFor
249+ :: forall m a b. (Applicative m, Monoid b)
250+ => (a -> Bool)
251+ -> FilePath
252+ -> PathTree a
253+ -> (FilePath -> PathTree a -> m b)
254+ -> m b
255+foldPathTreeFor predicate parent children f = case children of
256+ PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children')
257+ PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' ->
258+ foldPathTreeFor predicate (parent </> k) children'' f
259+
260+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
261+ deriving (Eq, Ord, Show)
262+instance Exception GuessPackageFileError
263+
264+newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
265+newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
266+
267+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
268+guessCabalPackageFile
269+ :: (MonadIO m)
270+ => FilePath -- ^ Directory or path to search for cabal package
271+ -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
272+guessCabalPackageFile pkg = do
273+ liftIO (doesDirectoryExist pkg) >>= \case
274+ False -> case cabalOrHpackFile pkg of
275+ (Just hpack@(Right _)) -> pure $ Right hpack
276+ (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
277+ -- If the cabal file has a sibling hpack file, we use that instead
278+ -- since running hpack often generates a sibling cabal file
279+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
280+ hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
281+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
282+ Nothing -> pure $ Left GuessPackageFileError_NotFound
283+ True -> do
284+ candidates <- liftIO $
285+ filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
286+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
287+ pure $ case partitionEithers candidates of
288+ ([hpack], _) -> Right $ Left hpack
289+ ([], [cabal]) -> Right $ Right cabal
290+ ([], []) -> Left GuessPackageFileError_NotFound
291+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
292+
293+cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
294+cabalOrHpackFile = \case
295+ x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
296+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
297+ | otherwise -> Nothing
298+
299+-- | Parses the cabal package in a given directory.
300+-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
301+parseCabalPackage
302+ :: MonadObelisk m
303+ => FilePath -- ^ Package directory
304+ -> m (Maybe CabalPackageInfo)
305+parseCabalPackage dir = parseCabalPackage' dir >>= \case
306+ Left err -> Nothing <$ putLog Error err
307+ Right (Just (warnings, pkgInfo)) -> do
308+ for_ warnings $ putLog Warning . T.pack . show
309+ pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
311+
312+-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313+parseCabalPackage'
314+ :: (MonadIO m)
315+ => FilePath -- ^ Package directory
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
317+parseCabalPackage' pkg = runExceptT $ do
318+ (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
320+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
321+ Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
322+ Right (Right (HPackFilePath file)) -> do
323+ let
324+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
325+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
326+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
327+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
328+
329+ let
330+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
331+ osConfVar = case System.Info.os of
332+ "linux" -> Just Dist.Linux
333+ "darwin" -> Just Dist.OSX
334+ _ -> trace "Unrecgonized System.Info.os" Nothing
335+ archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
336+ evalConfVar v = Right $ case v of
337+ OS osVar -> Just osVar == osConfVar
338+ Arch archVar -> Just archVar == archConfVar
339+ Impl GHC _ -> True -- TODO: Actually check version range
340+ _ -> False
341+ case condLibrary <$> result of
342+ Right (Just condLib) -> do
343+ let (_, lib) = simplifyCondTree evalConfVar condLib
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
345+ { _cabalPackageInfo_packageName = T.pack packageName
346+ , _cabalPackageInfo_packageFile = packageFile
347+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile
348+ , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
349+ , _cabalPackageInfo_sourceDirs =
350+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
351+ , _cabalPackageInfo_defaultExtensions =
352+ defaultExtensions $ libBuildInfo lib
353+ , _cabalPackageInfo_defaultLanguage =
354+ defaultLanguage $ libBuildInfo lib
355+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
357+ }
358+ Right Nothing -> pure Nothing
359+ Left (_, errors) ->
360+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
361+
362+parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
363+parsePackagesOrFail dirs' = do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
365+ flip fmap (parseCabalPackage dir) $ \case
366+ Just packageInfo
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
369+
370+ -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371+ let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
372+ $ Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
373+ unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
374+ p NE.:| [] -> pure p -- No ambiguity here
375+ p NE.:| _ -> do
376+ let chosenText = " [Chosen] "
377+ prefix p'
378+ | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText
379+ | otherwise = T.map (const ' ') chosenText
380+ putLog Warning $ T.unlines $
381+ "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "
382+ : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)
383+ pure p
384+
385+ packageInfos <- case NE.nonEmpty $ toList unambiguous of
386+ Nothing -> failWith $ T.pack $
387+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
388+ Just xs -> pure xs
389+
390+ pure packageInfos
391+ where
392+ dirs = toList dirs'
393+
394+packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
396+
397+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
398+withGhciScriptArgs
399+ :: (MonadObelisk m, Foldable f)
400+ => f CabalPackageInfo -- ^ List of packages to load into ghci
401+ -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
402+ -> m ()
403+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
404+ where
405+ -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
406+ -- is passed to the ghci session.
407+ loadPreludeManually =
408+ [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
409+ , ":set -XImplicitPrelude" -- Turn the default setting on
410+ ]
411+
412+-- | Create ghci configuration to load the given packages
413+withGhciScript
414+ :: (MonadObelisk m, Foldable f)
415+ => [String] -- ^ Commands to prefix to file
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
417+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
418+ -> m ()
419+withGhciScript preCommands (toList -> packageInfos) f =
51420 withSystemTempDirectory "ob-ghci" $ \fp -> do
52421 let dotGhciPath = fp </> ".ghci"
53− writeFile dotGhciPath dotGhci
54− runDev dotGhciPath $ Just testCmd
55−
56−-- | Relative paths to local packages of an obelisk project
57−-- TODO a way to query this
58−getLocalPkgs :: IO [FilePath]
59−getLocalPkgs = return ["backend", "common", "frontend"]
60−
61−parseHsSrcDir :: FilePath -- ^ package cabal file path
62− -> IO (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component
63−parseHsSrcDir cabalFp = do
64− exists <- doesFileExist cabalFp
65− if exists
66− then do
67− withUTF8FileContents cabalFp $ \cabal -> do
68− case parseGenericPackageDescription cabal of
69− ParseOk warnings gpkg -> do
70− mapM_ print warnings
71− return $ do
72− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
73− pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
74− ParseFailed _ -> return Nothing
75− else return Nothing
76−
77−-- | Dev
78−runDev :: FilePath -> Maybe String -> IO ()
79−runDev dotGhci mcmd = callCommand $ unwords $ "ghcid" : ghcidOpts
422+ liftIO $ writeFile dotGhciPath dotGhci
423+ f dotGhciPath
424+ where
425+ packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
426+ modulesToLoad = mconcat
427+ [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
428+ , [ "Backend" | "backend" `Set.member` packageNames ]
429+ , [ "Frontend" | "frontend" `Set.member` packageNames ]
430+ ]
431+ dotGhci = unlines $
432+ preCommands <>
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434+ , "import qualified Obelisk.Run"
435+ , "import qualified Frontend"
436+ , "import qualified Backend"
437+ ]
438+
439+-- | Builds a list of options to pass to ghci or set in .ghci file that configures
440+-- the preprocessor and source includes.
441+getGhciSessionSettings
442+ :: (MonadObelisk m, Foldable f)
443+ => f CabalPackageInfo -- ^ List of packages to load into ghci
444+ -> FilePath -- ^ All paths will be relative to this path
445+ -> Bool -- ^ Use relative paths
446+ -> m [String]
447+getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
448+ -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
449+ -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
450+ -- all paths to 'pathBase'.
451+ selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
452+ canonicalPathBase <- liftIO $ canonicalizePath pathBase
453+
454+ (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
455+ canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
456+ canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
457+ pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
458+
459+ pure
460+ $ baseGhciOptions
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
462+ <> concatMap (\p -> ["-optF", p]) pkgFiles
463+ <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
80464 where
81− ghcidOpts =
82− [ "-W"
83− , "--command='ghci -ghci-script " <> dotGhci <> "' "
84− ] <> maybeToList (flip fmap mcmd $ \cmd -> " --test=$'" <> cmd <> "'")
85−
86−getFreePort :: IO PortNumber
87−getFreePort = withSocketsDo $ do
88− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
89− E.bracket (open addr) close socketPort
465+ relativeTo' = if useRelativePaths then relativeTo else const
466+
467+baseGhciOptions :: [String]
468+baseGhciOptions =
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
472+ ]
473+
474+-- | Run ghci repl
475+runGhciRepl
476+ :: (MonadObelisk m, Foldable f)
477+ => FilePath -- ^ Path to project root
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
479+ -> [String] -- ^ GHCi arguments
480+ -> m ()
481+runGhciRepl root (toList -> packages) ghciArgs =
482+ -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
483+ -- ghc that is provided by the shell in the user's project.
484+ nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
486+
487+-- | Run ghcid
488+runGhcid
489+ :: (MonadObelisk m, Foldable f)
490+ => FilePath -- ^ Path to project root
491+ -> Bool -- ^ Should we chdir to root when running this process?
492+ -> [String] -- ^ GHCi arguments
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
494+ -> Maybe String -- ^ Optional command to run at every reload
495+ -> m ()
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
499+ where
500+ opts = concat
501+ [ ["-W"]
502+ , ["--outputfile=ghcid-output.txt"]
503+ , map (\x -> "--reload=" <> x) reloadFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
507+ ]
508+ adjustRoot x = if chdirToRoot then makeRelative root x else x
509+ reloadFiles = map adjustRoot [root </> "config"]
510+ restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
511+
512+getFreePort :: MonadIO m => m Socket.PortNumber
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
515+ bracket (open addr) Socket.close Socket.socketPort
90516 where
91517 open addr = do
92− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
93− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
94520 return sock
521+
522+
523+-- | Convert a 'FilePath' into a 'PathTree'.
524+pathToTree :: a -> FilePath -> PathTree a
525+pathToTree a p = go $ splitDirectories p
526+ where
527+ go [] = PathTree_Node (Just a) mempty
528+ go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
529+
530+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
531+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
532+zipDefaultWith _da _db _f [] [] = []
533+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
534+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
535+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
536+
537+-- | Makes the first absolute path relative to the second absolute path.
538+--
539+-- Both input paths MUST be absolute.
540+--
541+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
542+-- enough @..@ paths to make the resulting path truly relative in virtually every
543+-- case. The only exception is on Windows when the two paths are on different
544+-- drives. In this case the resulting path may be absolute.
545+relativeTo :: FilePath -> FilePath -> FilePath
546+relativeTo dir base
547+ = bifoldr1 (</>)
548+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
549+ $ unzip
550+ $ dropWhile (\(a,b) -> a == b)
551+ $ zipDefaultWith Nothing Nothing (,)
552+ (map Just $ splitDirectories base)
553+ (map Just $ splitDirectories dir)
554+ where collapse = foldr (</>) ""