git.iko.soy/obelisk
on master help sign in
command: Rewrite find in Haskell and provide 'some' level of type safe path manipulation
commit7b42ccf1c883fe1c0c867ec45f519f926e0bccae authorElliot Cameron <eacameron@gmail.com> dateFri 1 May 2020, 14:08 (6 years ago) parent662777e
5 files changed+259−145
compare with master
unifiedsplit
lib/command/obelisk-command.cabal+1−1 lib/command/src/Obelisk/Command.hs+2−6 lib/command/src/Obelisk/Command/Path.hs+196 lib/command/src/Obelisk/Command/Run.hs+60−135 lib/command/src/Obelisk/Command/Utils.hs−3
lib/command/obelisk-command.cabal+1−1
@@ -31,7 +31,6 @@ library
3131 , megaparsec
3232 , modern-uri
3333 , monad-loops
34− , monoidal-containers
3534 , mtl
3635 , network
3736 , network-uri
@@ -53,6 +52,7 @@ library
5352 Obelisk.Command
5453 Obelisk.Command.Deploy
5554 Obelisk.Command.Nix
55+ Obelisk.Command.Path
5656 Obelisk.Command.Project
5757 Obelisk.Command.Run
5858 Obelisk.Command.Thunk
lib/command/src/Obelisk/Command.hs+2−6
@@ -12,7 +12,6 @@ import Data.Foldable (for_)
1212import Data.List (isInfixOf, isPrefixOf)
1313import Data.List.NonEmpty (NonEmpty, nonEmpty)
1414import qualified Data.List.NonEmpty as NonEmpty
15−import qualified Data.Map as Map
1615import qualified Data.Text as T
1716import Data.Traversable (for)
1817import Options.Applicative
@@ -27,6 +26,7 @@ import System.Posix.Process (executeFile)
2726import Obelisk.App
2827import Obelisk.CliApp
2928import Obelisk.Command.Deploy
29+import Obelisk.Command.Path (PathTree, emptyPathTree, mergePathTreesRightBias, pathToTree)
3030import Obelisk.Command.Project
3131import Obelisk.Command.Run
3232import Obelisk.Command.Thunk
@@ -444,8 +444,4 @@ getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = Syste
444444resolveInterpretPaths :: MonadIO m => [(FilePath, a)] -> m (Maybe (PathTree a))
445445resolveInterpretPaths ps = do
446446 trees <- liftIO $ for ps $ \(p, a) -> pathToTree a <$> canonicalizePath p
447− pure $ foldr1 mergeTrees <$> nonEmpty trees
448− where
449− -- | Merge two 'PathTree's preferring leaves on the right in as much as they overlap with paths on the left.
450− mergeTrees :: PathTree a -> PathTree a -> PathTree a
451− mergeTrees (PathTree_Node ax x) (PathTree_Node ay y) = PathTree_Node (ay <|> ax) $ Map.unionWith mergeTrees x y
447+ pure $ foldr1 mergePathTreesRightBias <$> nonEmpty trees
lib/command/src/Obelisk/Command/Path.hsnew file+196
@@ -0,0 +1,196 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+
11+-- | An extremely low-ambition version of an opaque 'Path' library.
12+-- Libraries exist with much stronger guarantees but few (if any) of them
13+-- capture the idea of "canonical" paths in the types, which is critical
14+-- to many algorithms. Also they "buy-in" necessary for these approaches
15+-- is very high. This module provides the a minimal amount of type-level
16+-- tagging to allow the programmer to keep tabs on what's going on with
17+-- paths while also adding very little friction to interact with
18+-- 'FilePath'-based standard tools.
19+module Obelisk.Command.Path where
20+
21+import Control.Applicative ((<|>))
22+import Control.Exception (IOException, catch)
23+import Control.Monad.IO.Class (MonadIO, liftIO)
24+import Data.Bifoldable (bifoldr1)
25+import Data.Bifunctor (bimap)
26+import Data.Foldable (fold)
27+import Data.Map (Map)
28+import qualified Data.Map as Map
29+import Data.Maybe (catMaybes)
30+import Data.Set (Set)
31+import qualified Data.Set as Set
32+import Data.Text (Text)
33+import qualified Data.Text as T
34+import Data.Traversable (for)
35+import qualified System.Directory as Directory
36+import qualified System.FilePath as FilePath
37+import Data.Coerce (Coercible, coerce)
38+
39+-- | A newtype over 'FilePath' with a phantom type parameter to allow for various tagging mechanisms.
40+newtype Path t = Path { unPath :: FilePath } deriving (Eq, Ord)
41+instance Show (Path t) where
42+ show (Path p) = show p
43+
44+-- | A 'Path' tag indicating that the path is canonical
45+data Canonical
46+
47+-- | A 'Path' tag indicating that the path is absolute
48+data Absolute
49+
50+-- | A 'Path' tag indicating that the path is relative
51+data Relative
52+
53+
54+type IsPath path = Coercible path FilePath
55+
56+infixr 5 </>
57+(</>) :: (IsPath path1, IsPath path2) => path1 -> path2 -> FilePath
58+a </> b = coerce a FilePath.</> coerce b
59+
60+rel :: FilePath -> Path Relative
61+rel = coerce
62+
63+canonicalizePath :: (MonadIO m, IsPath path) => path -> m (Path Canonical)
64+canonicalizePath p = liftIO $ Path <$> Directory.canonicalizePath (coerce p)
65+
66+makeAbsolute :: (MonadIO m, IsPath path) => path -> m (Path Absolute)
67+makeAbsolute p = liftIO $ Path <$> Directory.makeAbsolute (coerce p)
68+
69+listDirectory :: (MonadIO m, IsPath path) => path -> m [Path Relative]
70+listDirectory p = liftIO $ coerce <$> Directory.listDirectory (coerce p)
71+
72+splitDirectories :: IsPath path => path -> [String]
73+splitDirectories p = FilePath.splitDirectories (coerce p)
74+
75+splitPath :: IsPath path => path -> [String]
76+splitPath p = FilePath.splitPath (coerce p)
77+
78+createDirectoryIfMissing :: (MonadIO m, IsPath path) => Bool -> path -> m ()
79+createDirectoryIfMissing makeParents p = liftIO $ Directory.createDirectoryIfMissing makeParents (coerce p)
80+
81+doesDirectoryExist :: (MonadIO m, IsPath path) => path -> m Bool
82+doesDirectoryExist p = liftIO $ Directory.doesDirectoryExist (coerce p)
83+
84+doesFileExist :: (MonadIO m, IsPath path) => path -> m Bool
85+doesFileExist p = liftIO $ Directory.doesFileExist (coerce p)
86+
87+takeDirectory :: Path t -> Path t
88+takeDirectory (Path p) = Path $ FilePath.takeDirectory p
89+
90+takeFileName :: IsPath path => path -> Path Relative
91+takeFileName p = Path $ FilePath.takeFileName (coerce p)
92+
93+takeBaseName :: IsPath path => path -> String
94+takeBaseName p = FilePath.takeBaseName (coerce p)
95+
96+takeExtension :: IsPath path => path -> String
97+takeExtension p = FilePath.takeExtension (coerce p)
98+
99+makeRelative :: (IsPath path1, IsPath path2) => path1 -> path2 -> FilePath
100+makeRelative a b = FilePath.makeRelative (coerce a) (coerce b)
101+
102+data FindMatch a = FindMatch_SkipTree | FindMatch_SearchTree | FindMatch_Match a
103+
104+-- | Like @find@ utility but in Haskell. Note that it follows symlinks!
105+findFiles'
106+ :: forall a path m. (MonadIO m, Monoid a, IsPath path)
107+ => (FilePath -> Path Canonical -> m (FindMatch a)) -- ^ Decide how to handle an encountered path.
108+ -> path -- ^ Root path to start searching
109+ -> m a -- ^ Matches
110+findFiles' match p' = go mempty (coerce p')
111+ where
112+ go :: Set (Path Canonical) -> FilePath -> m a
113+ go visited path = do
114+ canonicalPath <- canonicalizePath path
115+ if canonicalPath `Set.member` visited
116+ then pure mempty
117+ else match path canonicalPath >>= \case
118+ FindMatch_SkipTree -> pure mempty
119+ FindMatch_Match x -> pure x
120+ FindMatch_SearchTree -> do
121+ contents <- liftIO $ listDirectory canonicalPath `catch` \(_ :: IOException) -> pure []
122+ let visited' = Set.insert canonicalPath visited
123+ fmap fold $ for contents $ \p -> go visited' (path </> p)
124+
125+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
126+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
127+zipDefaultWith _da _db _f [] [] = []
128+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
129+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
130+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
131+
132+-- | Makes the first absolute path relative to the second absolute path.
133+--
134+-- Both input paths MUST be canonical.
135+--
136+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
137+-- enough @..@ paths to make the resulting path truly relative in virtually every
138+-- case. The only exception is on Windows when the two paths are on different
139+-- drives. In this case the resulting path may be absolute.
140+relativeTo :: Path Canonical -> Path Canonical -> FilePath
141+relativeTo dir base
142+ = bifoldr1 (</>)
143+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
144+ $ unzip
145+ $ dropWhile (uncurry (==))
146+ $ zipDefaultWith Nothing Nothing (,)
147+ (map Just $ splitDirectories base)
148+ (map Just $ splitDirectories dir)
149+ where collapse = foldr (FilePath.</>) ""
150+
151+
152+-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
153+data PathTree a = PathTree_Node
154+ (Maybe a) -- An optional leaf at this point in the tree
155+ (Map FilePath (PathTree a)) -- Branches to deeper leaves
156+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
157+
158+emptyPathTree :: PathTree a
159+emptyPathTree = PathTree_Node Nothing mempty
160+
161+-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
162+drawPathTree :: (a -> Text) -> PathTree a -> Text
163+drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
164+ where
165+ annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
166+ goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
167+ goForest [] = []
168+ goForest [tree] = shift "└─ " " " (goTree tree)
169+ goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
170+ shift first other = zipWith (<>) (first : repeat other)
171+
172+-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
173+foldPathTreeFor
174+ :: forall m a b. (Applicative m, Monoid b)
175+ => (a -> Bool)
176+ -> FilePath
177+ -> PathTree a
178+ -> (FilePath -> PathTree a -> m b) -- ^ Decide how to collect this node given its path and its children
179+ -> m b
180+foldPathTreeFor predicate parent children f = case children of
181+ PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children')
182+ PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' ->
183+ foldPathTreeFor predicate (parent </> k) children'' f
184+
185+-- | Convert a 'FilePath' into a 'PathTree'.
186+pathToTree :: IsPath path => a -> path -> PathTree a
187+pathToTree a p = go $ splitDirectories p
188+ where
189+ go [] = PathTree_Node (Just a) mempty
190+ go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
191+
192+-- | Merge two 'PathTree's preferring leaves on the right when they match the left.
193+mergePathTreesRightBias :: PathTree a -> PathTree a -> PathTree a
194+mergePathTreesRightBias (PathTree_Node ax x) (PathTree_Node ay y) =
195+ PathTree_Node (ay <|> ax) $ Map.unionWith mergePathTreesRightBias x y
196+
lib/command/src/Obelisk/Command/Run.hs+60−135
@@ -1,6 +1,3 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveTraversable #-}
41{-# LANGUAGE FlexibleContexts #-}
52{-# LANGUAGE LambdaCase #-}
63{-# LANGUAGE MultiParamTypeClasses #-}
@@ -18,18 +15,16 @@ import Control.Monad (filterM, unless, void)
1815import Control.Monad.Except (runExceptT, throwError)
1916import Control.Monad.IO.Class (liftIO)
2017import Control.Monad.Reader (MonadIO)
21−import Data.Bifoldable (bifoldr1)
22−import Data.Bifunctor (bimap)
2318import Data.Coerce (coerce)
2419import Data.Default (def)
2520import Data.Either (partitionEithers)
2621import Data.Foldable (fold, for_, toList)
22+import Data.Functor ((<&>))
2723import Data.Functor.Identity (runIdentity)
2824import Data.List.NonEmpty (NonEmpty)
2925import qualified Data.List.NonEmpty as NE
3026import Data.Map (Map)
3127import qualified Data.Map as Map
32−import qualified Data.Map.Monoidal as MMap
3328import Data.Maybe
3429import Data.Set (Set)
3530import qualified Data.Set as Set
@@ -55,9 +50,7 @@ import qualified Hpack.Render as Hpack
5550import qualified Hpack.Yaml as Hpack
5651import Language.Haskell.Extension
5752import Network.Socket hiding (Debug)
58−import System.Directory
5953import System.Environment (getExecutablePath)
60−import System.FilePath
6154import qualified System.Info
6255import System.IO.Temp (withSystemTempDirectory)
6356
@@ -68,7 +61,6 @@ import Obelisk.CliApp (
6861 failWith,
6962 proc,
7063 putLog,
71− readCreateProcessWithExitCode,
7264 readProcessAndLogStderr,
7365 setCwd,
7466 setDelegateCtlc,
@@ -76,9 +68,10 @@ import Obelisk.CliApp (
7668 withSpinner,
7769 )
7870import Obelisk.Command.Nix
79−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
71+import Obelisk.Command.Path
72+import Obelisk.Command.Project (findProjectAssets, nixShellWithoutPkgs, obeliskDirName, withProjectRoot)
8073import Obelisk.Command.Thunk (attrCacheFileName)
81−import Obelisk.Command.Utils (findExePath, ghcidExePath)
74+import Obelisk.Command.Utils (ghcidExePath)
8275
8376data CabalPackageInfo = CabalPackageInfo
8477 { _cabalPackageInfo_packageFile :: FilePath
@@ -103,26 +96,6 @@ textInterpret = \case
10396 Interpret_Interpret -> "Interpret"
10497 Interpret_NoInterpret -> "NoInterpret"
10598
106−-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
107−data PathTree a = PathTree_Node
108− (Maybe a) -- An optional leaf at this point in the tree
109− (Map FilePath (PathTree a)) -- Branches to deeper leaves
110− deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
111−
112−emptyPathTree :: PathTree a
113−emptyPathTree = PathTree_Node Nothing mempty
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−
12699-- | Used to signal to obelisk that it's being invoked as a preprocessor
127100preprocessorIdentifier :: String
128101preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -148,10 +121,10 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
148121 putLog Debug $ "Assets impurely loaded from: " <> assets
149122 time <- liftIO getCurrentTime
150123 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)
124+ createDirectoryIfMissing True $ takeDirectory $ Path $ root </> profileBaseName
125+ putLog Debug [i|Storing profiled data under base name of ${root </> profileBaseName}|]
153126 freePort <- getFreePort
154− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
127+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> rel "bin" </> rel "ob-run") $
155128 [ show freePort
156129 , T.unpack assets
157130 , profileBaseName
@@ -180,7 +153,7 @@ run root interpretPaths = do
180153runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
181154runRepl root interpretPaths = do
182155 pkgs <- getParsedLocalPkgs root interpretPaths
183− ghciArgs <- getGhciSessionSettings pkgs "." True
156+ ghciArgs <- getGhciSessionSettings pkgs (rel ".") True
184157 withGhciScript pkgs $ \dotGhciPath ->
185158 runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
186159
@@ -194,7 +167,7 @@ runWatch root interpretPaths = do
194167exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
195168exportGhciConfig useRelativePaths root interpretPaths = do
196169 pkgs <- getParsedLocalPkgs root interpretPaths
197− getGhciSessionSettings pkgs "." useRelativePaths
170+ getGhciSessionSettings pkgs (rel ".") useRelativePaths
198171
199172nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
200173nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
@@ -210,53 +183,37 @@ getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs ro
210183-- These are a combination of the obelisk predefined local packages,
211184-- and any packages that the user has set with the @packages@ argument
212185-- to the Nix @project@ function.
213−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
186+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set (Path Canonical))
214187getLocalPkgs root interpretPaths = do
215188 putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
216− obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
217189
218190 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
219191 -- obelisk project is our own.
220− obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
221− filter (/= root) $ map takeDirectory obeliskPackagePaths
222− putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
223− let rootsAndExclusions = calcIntepretFinds "" interpretPaths
224−
225− fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
226− let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
227− in fmap (Set.fromList . map normalise) $ runFind $
228− ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
229− <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
230− where
231− runFind args = do
232− (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
233− putLog Debug $ T.strip $ T.pack err
234− pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
235−
236−-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
237−-- This is used when constructing a set of @find@ commands to run to produce a set of packages
238−-- that matches the user's @--interpret@/@--no-interpret@ settings.
239−calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
240−calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
241− where
242− go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
243− exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
244− pure $ Map.singleton parent' children'
245− deeperFinds <- Map.traverseWithKey go exclusions
246− pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
247−
248−-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
249−foldPathTreeFor
250− :: forall m a b. (Applicative m, Monoid b)
251− => (a -> Bool)
252− -> FilePath
253− -> PathTree a
254− -> (FilePath -> PathTree a -> m b)
255− -> m b
256−foldPathTreeFor predicate parent children f = case children of
257− PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children')
258− PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' ->
259− foldPathTreeFor predicate (parent </> k) children'' f
192+ canonicalRoot <- canonicalizePath root
193+ obeliskPackageExclusions <- findFiles'
194+ (\_ p -> if takeFileName p == Path obeliskDirName && p /= canonicalRoot
195+ then liftIO (doesDirectoryExist p) <&> \case
196+ True -> FindMatch_Match $ Set.singleton p
197+ False -> FindMatch_SearchTree
198+ else pure FindMatch_SearchTree
199+ )
200+ root
201+
202+ putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ map show $ Set.toList obeliskPackageExclusions}|]
203+
204+ let
205+ findRoots = runIdentity $ foldPathTreeFor (== Interpret_Interpret) "" interpretPaths (\p _ -> pure $ Set.singleton $ Path p)
206+ exclusions = runIdentity $ foldPathTreeFor (== Interpret_NoInterpret) "" interpretPaths (\p _ -> pure $ Set.singleton $ Path p)
207+
208+ fmap fold $ for (toList findRoots) $ \interpretPathRoot -> do
209+ let allExclusions = obeliskPackageExclusions <> exclusions
210+ findFiles'
211+ (\_ p -> pure $ case () of
212+ _ | p `Set.member` allExclusions || attrCacheFileName `elem` splitDirectories p -> FindMatch_SkipTree
213+ | takeExtension p == ".cabal" || takeFileName p == rel Hpack.packageConfig -> FindMatch_Match $ Set.singleton p
214+ | otherwise -> FindMatch_SearchTree
215+ )
216+ interpretPathRoot
260217
261218data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
262219 deriving (Eq, Ord, Show)
@@ -267,17 +224,17 @@ newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (
267224
268225-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
269226guessCabalPackageFile
270− :: (MonadIO m)
271− => FilePath -- ^ Directory or path to search for cabal package
227+ :: (MonadIO m, IsPath path)
228+ => path -- ^ Directory or path to search for cabal package
272229 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
273−guessCabalPackageFile pkg = do
230+guessCabalPackageFile (coerce -> pkg) = do
274231 liftIO (doesDirectoryExist pkg) >>= \case
275232 False -> case cabalOrHpackFile pkg of
276233 (Just hpack@(Right _)) -> pure $ Right hpack
277234 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
278235 -- If the cabal file has a sibling hpack file, we use that instead
279236 -- since running hpack often generates a sibling cabal file
280− let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
237+ let possibleHpackSibling = takeDirectory (Path cabalFilePath) </> Hpack.packageConfig
281238 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
282239 pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
283240 Nothing -> pure $ Left GuessPackageFileError_NotFound
@@ -294,14 +251,14 @@ guessCabalPackageFile pkg = do
294251cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
295252cabalOrHpackFile = \case
296253 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
297− | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
254+ | takeFileName x == rel Hpack.packageConfig -> Just (Right $ HPackFilePath x)
298255 | otherwise -> Nothing
299256
300257-- | Parses the cabal package in a given directory.
301258-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
302259parseCabalPackage
303− :: MonadObelisk m
304− => FilePath -- ^ Package directory
260+ :: (MonadObelisk m, IsPath path)
261+ => path
305262 -> m (Maybe CabalPackageInfo)
306263parseCabalPackage dir = parseCabalPackage' dir >>= \case
307264 Left err -> Nothing <$ putLog Error err
@@ -311,10 +268,10 @@ parseCabalPackage dir = parseCabalPackage' dir >>= \case
311268
312269-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313270parseCabalPackage'
314− :: (MonadIO m)
315− => FilePath -- ^ Package directory
271+ :: (MonadIO m, IsPath path)
272+ => path -- ^ Package directory
316273 -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
317−parseCabalPackage' pkg = runExceptT $ do
274+parseCabalPackage' (coerce -> pkg) = runExceptT $ do
318275 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319276 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
320277 Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
@@ -344,7 +301,7 @@ parseCabalPackage' pkg = runExceptT $ do
344301 pure $ (warnings,) $ CabalPackageInfo
345302 { _cabalPackageInfo_packageName = T.pack packageName
346303 , _cabalPackageInfo_packageFile = packageFile
347− , _cabalPackageInfo_packageRoot = takeDirectory packageFile
304+ , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (Path packageFile)
348305 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
349306 , _cabalPackageInfo_sourceDirs =
350307 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
@@ -356,9 +313,9 @@ parseCabalPackage' pkg = runExceptT $ do
356313 }
357314 Right Nothing -> throwError "Haskell package has no library component"
358315 Left (_, errors) ->
359− throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
316+ throwError $ [i|Failed to parse ${packageFile}:|] <> "\n" <> T.pack (unlines (map show errors))
360317
361−parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
318+parsePackagesOrFail :: (MonadObelisk m, Foldable f, IsPath path) => f path -> m (NE.NonEmpty CabalPackageInfo)
362319parsePackagesOrFail dirs' = do
363320 (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364321 flip fmap (parseCabalPackage dir) $ \case
@@ -383,11 +340,11 @@ parsePackagesOrFail dirs' = do
383340
384341 packageInfos <- case NE.nonEmpty $ toList unambiguous of
385342 Nothing -> failWith $ T.pack $
386− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
343+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (coerce dirs))
387344 Just xs -> pure xs
388345
389346 unless (null pkgDirErrs) $
390− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
347+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (coerce pkgDirErrs)
391348
392349 pure packageInfos
393350 where
@@ -404,7 +361,7 @@ withGhciScript
404361 -> m ()
405362withGhciScript (toList -> packageInfos) f =
406363 withSystemTempDirectory "ob-ghci" $ \fp -> do
407− let dotGhciPath = fp </> ".ghci"
364+ let dotGhciPath = fp </> rel ".ghci"
408365 liftIO $ writeFile dotGhciPath dotGhci
409366 f dotGhciPath
410367 where
@@ -424,17 +381,17 @@ withGhciScript (toList -> packageInfos) f =
424381-- | Builds a list of options to pass to ghci or set in .ghci file that configures
425382-- the preprocessor and source includes.
426383getGhciSessionSettings
427− :: (MonadObelisk m, Foldable f)
384+ :: (MonadObelisk m, Foldable f, IsPath path)
428385 => f CabalPackageInfo -- ^ List of packages to load into ghci
429− -> FilePath -- ^ All paths will be relative to this path
386+ -> path -- ^ All paths will be relative to this path
430387 -> Bool -- ^ Use relative paths
431388 -> m [String]
432389getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
433390 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
434391 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
435392 -- all paths to 'pathBase'.
436− selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
437− canonicalPathBase <- liftIO $ canonicalizePath pathBase
393+ selfExe <- canonicalizePath =<< liftIO getExecutablePath
394+ canonicalPathBase <- canonicalizePath pathBase
438395
439396 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
440397 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
@@ -443,11 +400,11 @@ getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
443400
444401 pure
445402 $ baseGhciOptions
446− <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
403+ <> ["-F", "-pgmF", unPath selfExe, "-optF", preprocessorIdentifier]
447404 <> concatMap (\p -> ["-optF", p]) pkgFiles
448405 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
449406 where
450− relativeTo' = if useRelativePaths then relativeTo else const
407+ relativeTo' = if useRelativePaths then relativeTo else const . unPath
451408
452409baseGhciOptions :: [String]
453410baseGhciOptions =
@@ -492,11 +449,11 @@ runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
492449 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
493450
494451 adjustRoot x = if chdirToRoot then makeRelative root x else x
495− reloadFiles = map adjustRoot [root </> "config"]
452+ reloadFiles = map adjustRoot [root </> rel "config"]
496453 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
497454
498−mkGhciScriptArg :: FilePath -> [String]
499−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
455+mkGhciScriptArg :: IsPath path => path -> [String]
456+mkGhciScriptArg dotGhci = ["-ghci-script", coerce dotGhci]
500457
501458getFreePort :: MonadIO m => m PortNumber
502459getFreePort = liftIO $ withSocketsDo $ do
@@ -509,35 +466,3 @@ getFreePort = liftIO $ withSocketsDo $ do
509466 return sock
510467
511468
512−-- | Convert a 'FilePath' into a 'PathTree'.
513−pathToTree :: a -> FilePath -> PathTree a
514−pathToTree a p = go $ splitDirectories p
515− where
516− go [] = PathTree_Node (Just a) mempty
517− go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
518−
519−-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
520−zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
521−zipDefaultWith _da _db _f [] [] = []
522−zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
523−zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
524−zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
525−
526−-- | Makes the first absolute path relative to the second absolute path.
527−--
528−-- Both input paths MUST be absolute.
529−--
530−-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
531−-- enough @..@ paths to make the resulting path truly relative in virtually every
532−-- case. The only exception is on Windows when the two paths are on different
533−-- drives. In this case the resulting path may be absolute.
534−relativeTo :: FilePath -> FilePath -> FilePath
535−relativeTo dir base
536− = bifoldr1 (</>)
537− $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
538− $ unzip
539− $ dropWhile (\(a,b) -> a == b)
540− $ zipDefaultWith Nothing Nothing (,)
541− (map Just $ splitDirectories base)
542− (map Just $ splitDirectories dir)
543− where collapse = foldr (</>) ""
lib/command/src/Obelisk/Command/Utils.hs−3
@@ -42,9 +42,6 @@ rmPath = $(staticWhich "rm")
4242ghcidExePath :: FilePath
4343ghcidExePath = $(staticWhich "ghcid")
4444
45−findExePath :: FilePath
46−findExePath = $(staticWhich "find")
47−
4845nixExePath :: FilePath
4946nixExePath = $(staticWhich "nix")
5047