@@ -4,9 +4,11 @@
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
1113import Control.Monad.IO.Class (liftIO)
1214import Control.Monad.Reader (MonadIO)
@@ -24,9 +26,9 @@ import Distribution.Types.CondTree
2426import Distribution.Types.GenericPackageDescription
2527import Distribution.Types.Library
2628import Distribution.Utils.Generic
27−import Hpack.Config
28−import Hpack.Render
29−import Hpack.Yaml
29+import qualified Hpack.Config as Hpack
30+import qualified Hpack.Render as Hpack
31+import qualified Hpack.Yaml as Hpack
3032import Language.Haskell.Extension
3133import Network.Socket hiding (Debug)
3234import System.Directory
@@ -105,38 +107,50 @@ runWatch = do
105107 pkgs <- getLocalPkgs
106108 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
107109
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
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+
108131-- | Relative paths to local packages of an obelisk project
109132-- TODO a way to query this
110−getLocalPkgs :: Applicative f => f [(FilePath, Maybe String)]
111−getLocalPkgs = pure [("backend", Nothing), ("common", Nothing), ("frontend", Nothing)]
133+getLocalPkgs :: Applicative f => f [FilePath]
134+getLocalPkgs = pure ["backend", "common", "frontend"]
112135
113136parseCabalPackage
114137 :: (MonadObelisk m)
115138 => FilePath -- ^ package directory
116− -> Maybe String -- ^ package name, defaults to directory
117139 -> m (Maybe CabalPackageInfo)
118−parseCabalPackage dir name = do
119− let cabalFp = dir </> (fromMaybe (takeBaseName dir) name <> ".cabal")
120− hpackFp = dir </> "package.yaml"
121− hasCabal <- liftIO $ doesFileExist cabalFp
122− hasHpack <- liftIO $ doesFileExist hpackFp
123−
124− mCabalContents <- if hasCabal
125− then Just <$> liftIO (readUTF8File cabalFp)
126− else if hasHpack
127− then do
128− let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml
129− liftIO (readPackageConfig decodeOptions) >>= \case
130− Left err -> do
131− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
132− return Nothing
133− Right (DecodeResult hpackPackage _ _ _) -> do
134− return $ Just $ renderPackage [] hpackPackage
135− else do
136− putLog Error $ T.pack "Found neither cabal nor hpack file"
137− return Nothing
140+parseCabalPackage dir = do
141+ package <- guessCabalPackageFile dir >>= \case
142+ Left GuessPackageFileError_NotFound -> Nothing <$ putLog Error ("No .cabal or package.yaml file found in " <> T.pack dir)
143+ Left (GuessPackageFileError_Ambiguous _) -> Nothing <$ putLog Error ("Unable to determine which .cabal file to use in " <> T.pack dir)
144+ Right (Right cabalFileName) -> let file = dir </> cabalFileName in Just . (, 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 -> Nothing <$ putLog Error (T.pack $ "Failed to parse " <> file <> ": " <> err)
151+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure $ Just (Hpack.renderPackage [] hpackPackage, file)
138152
139− fmap join $ forM mCabalContents $ \cabalContents -> do
153+ fmap join $ forM package $ \(cabalContents, packageFile) -> do
140154 let (warnings, result) = runParseResult $ parseGenericPackageDescription $
141155 toUTF8BS cabalContents
142156 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
@@ -145,7 +159,7 @@ parseCabalPackage dir name = do
145159 return $ do
146160 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
147161 pure $ CabalPackageInfo
148− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
162+ { _cabalPackageInfo_packageRoot = dir
149163 , _cabalPackageInfo_sourceDirs =
150164 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
151165 , _cabalPackageInfo_defaultExtensions =
@@ -155,7 +169,7 @@ parseCabalPackage dir name = do
155169 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
156170 }
157171 Left (_, errors) -> do
158− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
172+ putLog Error $ T.pack $ "Failed to parse " <> packageFile <> ":"
159173 mapM_ (putLog Error) $ fmap (T.pack . show) errors
160174 return Nothing
161175
@@ -167,16 +181,15 @@ withUTF8FileContentsM fp f = do
167181-- | Create ghci configuration to load the given packages
168182withGhciScript
169183 :: MonadObelisk m
170− => [(FilePath, Maybe String)] -- ^ List of packages to load into ghci
184+ => [FilePath] -- ^ List of packages to load into ghci
171185 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
172186 -> m ()
173−withGhciScript pkgs f = do
174− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \(dir, name) -> do
175− flip fmap (parseCabalPackage dir name) $ \case
187+withGhciScript dirs f = do
188+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
189+ flip fmap (parseCabalPackage dir) $ \case
176190 Nothing -> Left dir
177191 Just packageInfo -> Right packageInfo
178192
179− let dirs = fmap fst pkgs
180193 when (null packageInfos) $
181194 failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
182195 unless (null pkgDirErrs) $