@@ -7,27 +7,32 @@
77{-# LANGUAGE TupleSections #-}
88module Obelisk.Command.Run where
99
10−import Control.Applicative (liftA2)
1110import Control.Exception (Exception, bracket)
12−import Control.Monad
11+import Control.Monad (filterM, unless, when)
1312import Control.Monad.Except (runExceptT, throwError)
1413import Control.Monad.IO.Class (liftIO)
1514import Control.Monad.Reader (MonadIO)
15+import Data.Containers.ListUtils (nubOrd)
16+import Data.Coerce (coerce)
1617import Data.Either
1718import Data.Foldable (for_)
1819import qualified Data.List as L
1920import qualified Data.List.NonEmpty as NE
2021import Data.Maybe
2122import qualified Data.Text as T
23+import Data.Traversable (for)
24+import Debug.Trace (trace)
2225import Distribution.Compiler (CompilerFlavor(..))
2326import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
2427import Distribution.Parsec.ParseResult (runParseResult)
2528import Distribution.Pretty
29+import qualified Distribution.System as Dist
2630import Distribution.Types.BuildInfo
2731import Distribution.Types.CondTree
2832import Distribution.Types.GenericPackageDescription
2933import Distribution.Types.Library
3034import Distribution.Utils.Generic
35+import qualified Distribution.Parsec.Common as Dist
3136import qualified Hpack.Config as Hpack
3237import qualified Hpack.Render as Hpack
3338import qualified Hpack.Yaml as Hpack
@@ -35,15 +40,18 @@ import Language.Haskell.Extension
3540import Network.Socket hiding (Debug)
3641import System.Directory
3742import System.FilePath
43+import qualified System.Info
3844import System.IO.Temp (withSystemTempDirectory)
3945import System.Which (staticWhich)
4046
4147import Obelisk.App (MonadObelisk, ObeliskT)
42−import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr, readProcessJSONAndLogStderr)
48+import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
4349import Obelisk.Command.Project (inProjectShell, withProjectRoot)
4450
4551data CabalPackageInfo = CabalPackageInfo
46− { _cabalPackageInfo_packageRoot :: FilePath
52+ { _cabalPackageInfo_packageFile :: FilePath
53+ , _cabalPackageInfo_packageName :: T.Text
54+ , _cabalPackageInfo_packageRoot :: FilePath
4755 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
4856 -- ^ List of hs src dirs of the library component
4957 , _cabalPackageInfo_defaultExtensions :: [Extension]
@@ -87,7 +95,7 @@ run = withProjectRoot "." $ \root -> do
8795 runGhcid dotGhciPath $ Just $ unwords
8896 [ "Obelisk.Run.run"
8997 , show freePort
90− , "(runServeAsset " ++ show assets ++ ")"
98+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
9199 , "Backend.backend"
92100 , "Frontend.frontend"
93101 ]
@@ -117,68 +125,103 @@ runWatch = do
117125-- to the Nix @project@ function.
118126getLocalPkgs :: (MonadObelisk m, MonadIO m) => FilePath -> m [FilePath]
119127getLocalPkgs root = do
120− root' <- liftIO $ makeAbsolute root
121− -- package paths from nix project will be absolute paths
122− projectPackages <- readProcessJSONAndLogStderr Debug $
123− proc "nix"
124− [ "eval"
125− , "(let proj = import " <> root <> " {}; in (map toString (proj.obelisk.reflex-platform.nixpkgs.lib.attrValues (proj.passthru.packages or {}))))"
126− , "--json"
127− ]
128− pure $ predefinedLocalPkgs ++ map (makeRelative root') projectPackages
129−
130−-- | Relative paths to the predefined obelisk project packages.
131−-- (See @predefinedPackages@ in @default.nix@)
132−predefinedLocalPkgs :: [FilePath]
133−predefinedLocalPkgs = ["backend", "common", "frontend"]
134−
128+ let findPath = $(staticWhich "find")
129+ (_exitCode, out, err') <- readCreateProcessWithExitCode $
130+ proc findPath ["-L", root, "-name", "*.cabal", "-o", "-name", Hpack.packageConfig]
131+ case T.strip $ T.pack err' of
132+ err | T.null err -> pure ()
133+ | otherwise -> putLog Debug err
134+ let unpackedPackagesRelative = lines . T.unpack $ T.strip $ T.pack out
135+ rootAbs <- liftIO $ makeAbsolute root
136+ pure $ nubOrd $ flip map unpackedPackagesRelative (rootAbs </>)
135137
136138data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
137139 deriving (Eq, Ord, Show)
138140instance Exception GuessPackageFileError
139141
142+newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
143+newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
144+
140145-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
141146guessCabalPackageFile
142− :: MonadIO m
143− => FilePath -- ^ Directory to search for cabal package
144− -> m (Either GuessPackageFileError (Either FilePath FilePath))
145− -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.
146−guessCabalPackageFile dir = do
147− candidates <- liftIO $
148− filterM (doesFileExist . (dir </>))
149− =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))
150− <$> listDirectory dir
151− pure $ case L.partition (== Hpack.packageConfig) candidates of
152− ([hpack], _) -> Right $ Left hpack
153− ([], [cabal]) -> Right $ Right cabal
154− ([], []) -> Left GuessPackageFileError_NotFound
155− (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals
147+ :: (MonadIO m)
148+ => FilePath -- ^ Directory or path to search for cabal package
149+ -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
150+guessCabalPackageFile pkg = do
151+ liftIO (doesDirectoryExist pkg) >>= \case
152+ False -> case cabalOrHpackFile pkg of
153+ (Just hpack@(Right _)) -> pure $ Right hpack
154+ (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
155+ -- If the cabal file has a sibling hpack file, we use that instead
156+ -- since running hpack often generates a sibling cabal file
157+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
158+ hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
159+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
160+ Nothing -> pure $ Left GuessPackageFileError_NotFound
161+ True -> do
162+ candidates <- liftIO $
163+ filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
164+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
165+ pure $ case partitionEithers candidates of
166+ ([hpack], _) -> Right $ Left hpack
167+ ([], [cabal]) -> Right $ Right cabal
168+ ([], []) -> Left GuessPackageFileError_NotFound
169+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
156170
171+cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
172+cabalOrHpackFile = \case
173+ x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
174+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
175+ | otherwise -> Nothing
176+
177+-- | Parses the cabal package in a given directory.
178+-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
157179parseCabalPackage
158− :: (MonadObelisk m)
159− => FilePath -- ^ package directory
180+ :: MonadObelisk m
181+ => FilePath -- ^ Package directory
160182 -> m (Maybe CabalPackageInfo)
161−parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do
162− (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case
163− Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir
164− Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir
165− Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)
166− Right (Left hpackFileName) -> do
183+parseCabalPackage dir = parseCabalPackage' dir >>= \case
184+ Left err -> Nothing <$ putLog Error err
185+ Right (warnings, pkgInfo) -> do
186+ for_ warnings $ putLog Warning . T.pack . show
187+ pure $ Just pkgInfo
188+
189+-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
190+parseCabalPackage'
191+ :: (MonadIO m)
192+ => FilePath -- ^ Package directory
193+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
194+parseCabalPackage' pkg = runExceptT $ do
195+ (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
196+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
197+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
198+ Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
199+ Right (Right (HPackFilePath file)) -> do
167200 let
168− file = dir </> hpackFileName
169201 decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
170202 liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
171203 Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
172− Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)
204+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
173205
174− let (warnings, result) = runParseResult $ parseGenericPackageDescription $
175− toUTF8BS cabalContents
176− for_ warnings $ putLog Warning . T.pack . show
206+ let
207+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
208+ osConfVar = case System.Info.os of
209+ "linux" -> Just Dist.Linux
210+ "darwin" -> Just Dist.OSX
211+ _ -> trace "Unrecgonized System.Info.os" Nothing
212+ archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
213+ evalConfVar v = Right $ case v of
214+ OS osVar -> Just osVar == osConfVar
215+ Arch archVar -> Just archVar == archConfVar
216+ Impl GHC _ -> True -- TODO: Actually check version range
217+ _ -> False
177218 case condLibrary <$> result of
178219 Right (Just condLib) -> do
179− let (_, lib) = simplifyCondTree (const $ pure True) condLib
180− pure $ CabalPackageInfo
181− { _cabalPackageInfo_packageRoot = dir
220+ let (_, lib) = simplifyCondTree evalConfVar condLib
221+ pure $ (warnings,) $ CabalPackageInfo
222+ { _cabalPackageInfo_packageName = T.pack packageName
223+ , _cabalPackageInfo_packageFile = packageFile
224+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile
182225 , _cabalPackageInfo_sourceDirs =
183226 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
184227 , _cabalPackageInfo_defaultExtensions =
@@ -198,37 +241,32 @@ withGhciScript
198241 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
199242 -> m ()
200243withGhciScript dirs f = do
201− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
244+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ for dirs $ \dir -> do
202245 flip fmap (parseCabalPackage dir) $ \case
203246 Nothing -> Left dir
204247 Just packageInfo -> Right packageInfo
205248
206249 when (null packageInfos) $
207− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
250+ failWith $ T.pack $ "No valid packages found in " <> intercalate ", " dirs
208251 unless (null pkgDirErrs) $
209− putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
252+ putLog Warning $ T.pack $ "Failed to find packages in " <> intercalate ", " pkgDirErrs
210253
211− let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
212− languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
213− -- NOTE when no default-language is present cabal sets Haskell98
214− language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
215− extensionsLine = if extensions == mempty
216− then ""
217− else ":set " <> unwords (("-X" <>) . prettyShow <$> extensions)
218− ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $
219− packageInfos >>= _cabalPackageInfo_compilerOptions
220− dotGhci = unlines
221− [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
222− , case ghcOptions of
223− [] -> ""
224− xs -> ":set " <> unwords xs
225− , extensionsLine
226− , ":set " <> unwords (("-X" <>) . prettyShow <$> language)
227− , ":load Backend Frontend"
228− , "import Obelisk.Run"
229− , "import qualified Frontend"
230− , "import qualified Backend"
231− ]
254+ let
255+ packageNames = map _cabalPackageInfo_packageName packageInfos
256+ languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
257+ -- NOTE when no default-language is present cabal sets Haskell98
258+ language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
259+ dotGhci = unlines
260+ [ ":set -pgmF ob-preprocessor " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
261+ , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
262+ , ":set " <> unwords (("-X" <>) . prettyShow <$> language)
263+ , ":load Backend Frontend"
264+ -- We need to also load 'Obelisk.Run' if it's part of our ghci session.
265+ <> if "obelisk-run" `elem` packageNames then " Obelisk.Run" else ""
266+ , "import qualified Obelisk.Run"
267+ , "import qualified Frontend"
268+ , "import qualified Backend"
269+ ]
232270 warnDifferentLanguages language
233271 withSystemTempDirectory "ob-ghci" $ \fp -> do
234272 let dotGhciPath = fp </> ".ghci"