@@ -4,15 +4,18 @@
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)
13−import Data.ByteString (ByteString)
1416import qualified Data.ByteString.UTF8 as BSU
1517import Data.Either
18+import Data.Foldable (for_)
1619import qualified Data.List as L
1720import qualified Data.List.NonEmpty as NE
1821import Data.Maybe
@@ -26,9 +29,9 @@ import Distribution.Types.CondTree
2629import Distribution.Types.GenericPackageDescription
2730import Distribution.Types.Library
2831import Distribution.Utils.Generic
29−import Hpack.Config
30−import Hpack.Render
31−import Hpack.Yaml
32+import qualified Hpack.Config as Hpack
33+import qualified Hpack.Render as Hpack
34+import qualified Hpack.Yaml as Hpack
3235import Language.Haskell.Extension
3336import Network.Socket hiding (Debug)
3437import System.Directory
@@ -38,10 +41,7 @@ import System.Which (staticWhich)
3841import Text.ShellEscape (bash, bytes)
3942
4043import Obelisk.App (MonadObelisk, ObeliskT)
41−import Obelisk.CliApp
42− ( CliT (..), HasCliConfig, Severity (..)
43− , callCommand, failWith, getCliConfig, putLog, proc
44− , readProcessAndLogStderr, runCli)
44+import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)
4545import Obelisk.Command.Project (inProjectProc, withProjectRoot)
4646
4747data CabalPackageInfo = CabalPackageInfo
@@ -107,6 +107,27 @@ runWatch = do
107107 pkgs <- getLocalPkgs
108108 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
109109
110+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
111+ deriving (Eq, Ord, Show)
112+instance Exception GuessPackageFileError
113+
114+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
115+guessCabalPackageFile
116+ :: MonadIO m
117+ => FilePath -- ^ Directory to search for cabal package
118+ -> m (Either GuessPackageFileError (Either FilePath FilePath))
119+ -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.
120+guessCabalPackageFile dir = do
121+ candidates <- liftIO $
122+ filterM (doesFileExist . (dir </>))
123+ =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))
124+ <$> listDirectory dir
125+ pure $ case L.partition (== Hpack.packageConfig) candidates of
126+ ([hpack], _) -> Right $ Left hpack
127+ ([], [cabal]) -> Right $ Right cabal
128+ ([], []) -> Left GuessPackageFileError_NotFound
129+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals
130+
110131-- | Relative paths to local packages of an obelisk project
111132-- TODO a way to query this
112133getLocalPkgs :: Applicative f => f [FilePath]
@@ -116,54 +137,38 @@ parseCabalPackage
116137 :: (MonadObelisk m)
117138 => FilePath -- ^ package directory
118139 -> m (Maybe CabalPackageInfo)
119−parseCabalPackage dir = do
120− let cabalFp = dir </> (takeBaseName dir <> ".cabal")
121− hpackFp = dir </> "package.yaml"
122− hasCabal <- liftIO $ doesFileExist cabalFp
123− hasHpack <- liftIO $ doesFileExist hpackFp
124−
125− mCabalContents <- if hasCabal
126− then Just <$> liftIO (readUTF8File cabalFp)
127− else if hasHpack
128− then do
129− let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml
130− liftIO (readPackageConfig decodeOptions) >>= \case
131− Left err -> do
132− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
133− return Nothing
134− Right (DecodeResult hpackPackage _ _ _) -> do
135− return $ Just $ renderPackage [] hpackPackage
136− else do
137− putLog Error $ T.pack "Found neither cabal nor hpack file"
138− return Nothing
139−
140− fmap join $ forM mCabalContents $ \cabalContents -> do
141− let (warnings, result) = runParseResult $ parseGenericPackageDescription $
142− toUTF8BS cabalContents
143− mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
144− case result of
145− Right gpkg -> do
146− return $ do
147− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
148− pure $ CabalPackageInfo
149− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
150− , _cabalPackageInfo_sourceDirs =
151− fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
152− , _cabalPackageInfo_defaultExtensions =
153− defaultExtensions $ libBuildInfo lib
154− , _cabalPackageInfo_defaultLanguage =
155− defaultLanguage $ libBuildInfo lib
156− , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
157− }
158− Left (_, errors) -> do
159− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
160− mapM_ (putLog Error) $ fmap (T.pack . show) errors
161− return Nothing
140+parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do
141+ (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case
142+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir
143+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir
144+ Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)
145+ Right (Left hpackFileName) -> do
146+ let
147+ file = dir </> hpackFileName
148+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
149+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
150+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
151+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)
162152
163−withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a
164−withUTF8FileContentsM fp f = do
165− c <- getCliConfig
166− liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS
153+ let (warnings, result) = runParseResult $ parseGenericPackageDescription $
154+ toUTF8BS cabalContents
155+ for_ warnings $ putLog Warning . T.pack . show
156+ case condLibrary <$> result of
157+ Right (Just condLib) -> do
158+ let (_, lib) = simplifyCondTree (const $ pure True) condLib
159+ pure $ CabalPackageInfo
160+ { _cabalPackageInfo_packageRoot = dir
161+ , _cabalPackageInfo_sourceDirs =
162+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
163+ , _cabalPackageInfo_defaultExtensions =
164+ defaultExtensions $ libBuildInfo lib
165+ , _cabalPackageInfo_defaultLanguage =
166+ defaultLanguage $ libBuildInfo lib
167+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
168+ }
169+ Right Nothing -> throwError "Haskell package has no library component"
170+ Left (_, errors) ->
171+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
167172
168173-- | Create ghci configuration to load the given packages
169174withGhciScript
@@ -171,14 +176,14 @@ withGhciScript
171176 => [FilePath] -- ^ List of packages to load into ghci
172177 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
173178 -> m ()
174−withGhciScript pkgs f = do
175− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
176− flip fmap (parseCabalPackage pkg) $ \case
177− Nothing -> Left pkg
179+withGhciScript dirs f = do
180+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
181+ flip fmap (parseCabalPackage dir) $ \case
182+ Nothing -> Left dir
178183 Just packageInfo -> Right packageInfo
179184
180185 when (null packageInfos) $
181− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
186+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
182187 unless (null pkgDirErrs) $
183188 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
184189
@@ -235,7 +240,7 @@ runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
235240 opts =
236241 [ "-W"
237242 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
238− , "--command=" <> (BSU.toString $ bytes $ bash $ BSU.fromString $
243+ , "--command=" <> BSU.toString (bytes $ bash $ BSU.fromString $
239244 "ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints " <> unwords (makeBaseGhciOptions dotGhci))
240245 , "--reload=config"
241246 , "--outputfile=ghcid-output.txt"