@@ -4,13 +4,17 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE ScopedTypeVariables #-}
66{-# LANGUAGE TemplateHaskell #-}
7+{-# LANGUAGE TupleSections #-}
78module Obelisk.Command.Run where
89
9−import Control.Exception (bracket)
10+import Control.Applicative (liftA2)
11+import Control.Exception (Exception, bracket)
1012import Control.Monad
13+import Control.Monad.Except (runExceptT, throwError)
1114import Control.Monad.IO.Class (liftIO)
1215import Control.Monad.Reader (MonadIO)
1316import Data.Either
17+import Data.Foldable (for_)
1418import qualified Data.List as L
1519import qualified Data.List.NonEmpty as NE
1620import Data.Maybe
@@ -24,22 +28,18 @@ import Distribution.Types.CondTree
2428import Distribution.Types.GenericPackageDescription
2529import Distribution.Types.Library
2630import Distribution.Utils.Generic
27−import Hpack.Config
28−import Hpack.Render
29−import Hpack.Yaml
31+import qualified Hpack.Config as Hpack
32+import qualified Hpack.Render as Hpack
33+import qualified Hpack.Yaml as Hpack
3034import Language.Haskell.Extension
3135import Network.Socket hiding (Debug)
3236import System.Directory
3337import System.FilePath
3438import System.IO.Temp (withSystemTempDirectory)
3539import System.Which (staticWhich)
36−import Data.ByteString (ByteString)
3740
3841import Obelisk.App (MonadObelisk, ObeliskT)
39−import Obelisk.CliApp
40− ( CliT (..), HasCliConfig, Severity (..)
41− , callCommand, failWith, getCliConfig, putLog, proc
42− , readProcessAndLogStderr, runCli)
42+import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)
4343import Obelisk.Command.Project (inProjectShell, withProjectRoot)
4444
4545data CabalPackageInfo = CabalPackageInfo
@@ -105,6 +105,27 @@ runWatch = do
105105 pkgs <- getLocalPkgs
106106 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
107107
108+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
109+ deriving (Eq, Ord, Show)
110+instance Exception GuessPackageFileError
111+
112+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
113+guessCabalPackageFile
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
128+
108129-- | Relative paths to local packages of an obelisk project
109130-- TODO a way to query this
110131getLocalPkgs :: Applicative f => f [FilePath]
@@ -114,54 +135,38 @@ parseCabalPackage
114135 :: (MonadObelisk m)
115136 => FilePath -- ^ package directory
116137 -> m (Maybe CabalPackageInfo)
117−parseCabalPackage dir = do
118− let cabalFp = dir </> (takeBaseName dir <> ".cabal")
119− hpackFp = dir </> "package.yaml"
120− hasCabal <- liftIO $ doesFileExist cabalFp
121− hasHpack <- liftIO $ doesFileExist hpackFp
122−
123− mCabalContents <- if hasCabal
124− then Just <$> liftIO (readUTF8File cabalFp)
125− else if hasHpack
126− then do
127− let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml
128− liftIO (readPackageConfig decodeOptions) >>= \case
129− Left err -> do
130− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
131− return Nothing
132− Right (DecodeResult hpackPackage _ _ _) -> do
133− return $ Just $ renderPackage [] hpackPackage
134− else do
135− putLog Error $ T.pack "Found neither cabal nor hpack file"
136− return Nothing
137−
138− fmap join $ forM mCabalContents $ \cabalContents -> do
139− let (warnings, result) = runParseResult $ parseGenericPackageDescription $
140− toUTF8BS cabalContents
141− mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
142− case result of
143− Right gpkg -> do
144− return $ do
145− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
146− pure $ CabalPackageInfo
147− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
148− , _cabalPackageInfo_sourceDirs =
149− fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
150− , _cabalPackageInfo_defaultExtensions =
151− defaultExtensions $ libBuildInfo lib
152− , _cabalPackageInfo_defaultLanguage =
153− defaultLanguage $ libBuildInfo lib
154− , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
155− }
156− Left (_, errors) -> do
157− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
158− mapM_ (putLog Error) $ fmap (T.pack . show) errors
159− return Nothing
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
144+ let
145+ file = dir </> hpackFileName
146+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
147+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
148+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
149+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)
160150
161−withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a
162−withUTF8FileContentsM fp f = do
163− c <- getCliConfig
164− liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS
151+ let (warnings, result) = runParseResult $ parseGenericPackageDescription $
152+ toUTF8BS cabalContents
153+ for_ warnings $ putLog Warning . T.pack . show
154+ case condLibrary <$> result of
155+ Right (Just condLib) -> do
156+ let (_, lib) = simplifyCondTree (const $ pure True) condLib
157+ pure $ CabalPackageInfo
158+ { _cabalPackageInfo_packageRoot = dir
159+ , _cabalPackageInfo_sourceDirs =
160+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
161+ , _cabalPackageInfo_defaultExtensions =
162+ defaultExtensions $ libBuildInfo lib
163+ , _cabalPackageInfo_defaultLanguage =
164+ defaultLanguage $ libBuildInfo lib
165+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
166+ }
167+ Right Nothing -> throwError "Haskell package has no library component"
168+ Left (_, errors) ->
169+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
165170
166171-- | Create ghci configuration to load the given packages
167172withGhciScript
@@ -169,14 +174,14 @@ withGhciScript
169174 => [FilePath] -- ^ List of packages to load into ghci
170175 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
171176 -> m ()
172−withGhciScript pkgs f = do
173− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
174− flip fmap (parseCabalPackage pkg) $ \case
175− Nothing -> Left pkg
177+withGhciScript dirs f = do
178+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
179+ flip fmap (parseCabalPackage dir) $ \case
180+ Nothing -> Left dir
176181 Just packageInfo -> Right packageInfo
177182
178183 when (null packageInfos) $
179− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
184+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
180185 unless (null pkgDirErrs) $
181186 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
182187