git.iko.soy/obelisk
on master help sign in
More type safe paths; simplify interpret paths; allow overriding obelisk project no-interpret
commit336973620672158fcfa018f2544afbbb02e41197 authorElliot Cameron <eacameron@gmail.com> dateSat 2 May 2020, 22:23 (6 years ago) parent7b42ccf
4 files changed+276−248
compare with master
unifiedsplit
lib/command/src/Obelisk/Command.hs+11−24 lib/command/src/Obelisk/Command/Path.hs+4−188 lib/command/src/Obelisk/Command/Path/Internal.hs+222 lib/command/src/Obelisk/Command/Run.hs+39−36
lib/command/src/Obelisk/Command.hs+11−24
@@ -6,12 +6,14 @@
66{-# LANGUAGE TupleSections #-}
77module Obelisk.Command where
88
9−import Control.Monad.IO.Class (MonadIO, liftIO)
9+import Control.Monad.IO.Class (liftIO)
1010import Data.Bool (bool)
1111import Data.Foldable (for_)
1212import Data.List (isInfixOf, isPrefixOf)
13−import Data.List.NonEmpty (NonEmpty, nonEmpty)
13+import Data.List.NonEmpty (NonEmpty)
1414import qualified Data.List.NonEmpty as NonEmpty
15+import Data.Map (Map)
16+import qualified Data.Map as Map
1517import qualified Data.Text as T
1618import Data.Traversable (for)
1719import Options.Applicative
@@ -26,7 +28,8 @@ import System.Posix.Process (executeFile)
2628import Obelisk.App
2729import Obelisk.CliApp
2830import Obelisk.Command.Deploy
29−import Obelisk.Command.Path (PathTree, emptyPathTree, mergePathTreesRightBias, pathToTree)
31+import Obelisk.Command.Path (Path, Canonical)
32+import qualified Obelisk.Command.Path as Path
3033import Obelisk.Command.Project
3134import Obelisk.Command.Run
3235import Obelisk.Command.Thunk
@@ -400,7 +403,7 @@ ob = \case
400403 ObCommand_Shell (ShellOpts shellAttr interpretPathsList cmd) -> withInterpretPaths interpretPathsList $ \root interpretPaths ->
401404 nixShellForInterpretPaths False shellAttr root interpretPaths cmd
402405 ObCommand_Doc shellAttr pkgs -> withProjectRoot "." $ \root ->
403− nixShellForInterpretPaths True shellAttr root emptyPathTree $ Just $ haddockCommand pkgs
406+ nixShellForInterpretPaths True shellAttr root mempty $ Just $ haddockCommand pkgs
404407 ObCommand_Hoogle shell' port -> withProjectRoot "." $ \root -> do
405408 nixShellWithHoogle root True shell' $ Just $ "hoogle server -p " <> show port <> " --local"
406409 ObCommand_Internal icmd -> case icmd of
@@ -411,12 +414,11 @@ ob = \case
411414
412415-- | A helper for the common case that the command you want to run needs the project root and a resolved
413416-- set of interpret paths.
414−withInterpretPaths :: MonadObelisk m => [(FilePath, Interpret)] -> (FilePath -> PathTree Interpret -> m a) -> m a
417+withInterpretPaths :: MonadObelisk m => [(FilePath, Interpret)] -> (FilePath -> Map (Path Canonical) Interpret -> m a) -> m a
415418withInterpretPaths interpretPathsList f = withProjectRoot "." $ \root -> do
416− interpretPaths' <- resolveInterpretPaths $ (root, Interpret_Interpret) : interpretPathsList
417− case interpretPaths' of
418− Nothing -> failWith "No paths provided for finding packages"
419− Just interpretPaths -> f root interpretPaths
419+ let fullList = (root, Interpret_Interpret) : interpretPathsList
420+ interpretPaths <- fmap Map.fromList $ for fullList $ \(p, i) -> (,i) <$> Path.canonicalizePath p
421+ f root interpretPaths
420422
421423haddockCommand :: [String] -> String
422424haddockCommand pkgs = unwords
@@ -430,18 +432,3 @@ haddockCommand pkgs = unwords
430432
431433getArgsConfig :: IO ArgsConfig
432434getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
433−
434−-- | Resolves an ordered list of paths for use with @--interpret@/@--no-interpret@ by coalescing
435−-- paths into a non-ambiguous set of paths. Ambiguity is resolved by choosing right-most paths
436−-- over any preceeding identical paths.
437−--
438−-- For example: @a/b=ON a/b/c=OFF@ and @a/b/c=OFF a/b=ON@ are the same.
439−-- @a/b=ON a/b=OFF@ is reduced to @a/b=OFF@. We prefer right-biased choice to increase
440−-- scriptability.
441−--
442−-- N.B. All the paths in the result will be canonicalized. It's impossible to determine path
443−-- overlap otherwise.
444−resolveInterpretPaths :: MonadIO m => [(FilePath, a)] -> m (Maybe (PathTree a))
445−resolveInterpretPaths ps = do
446− trees <- liftIO $ for ps $ \(p, a) -> pathToTree a <$> canonicalizePath p
447− pure $ foldr1 mergePathTreesRightBias <$> nonEmpty trees
lib/command/src/Obelisk/Command/Path.hs+4−188
@@ -1,196 +1,12 @@
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−
111-- | An extremely low-ambition version of an opaque 'Path' library.
122-- Libraries exist with much stronger guarantees but few (if any) of them
133-- capture the idea of "canonical" paths in the types, which is critical
14−-- to many algorithms. Also they "buy-in" necessary for these approaches
4+-- to many algorithms. Also the "buy-in" necessary for these approaches
155-- is very high. This module provides the a minimal amount of type-level
166-- tagging to allow the programmer to keep tabs on what's going on with
177-- paths while also adding very little friction to interact with
188-- '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
9+module Obelisk.Command.Path (module Reexport) where
19610
11+import Obelisk.Command.Path.Internal as Reexport hiding (Path (..))
12+import Obelisk.Command.Path.Internal as Reexport (Path, unPath)
lib/command/src/Obelisk/Command/Path/Internal.hsnew file+222
@@ -0,0 +1,222 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE EmptyDataDecls #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-} -- For recursive definitions of 'PathConcatResult'
14+module Obelisk.Command.Path.Internal where
15+
16+import Control.Exception (IOException, catch)
17+import Control.Monad.IO.Class (MonadIO, liftIO)
18+import Data.Bifoldable (bifoldr1)
19+import Data.Bifunctor (bimap)
20+import Data.Foldable (fold)
21+import Data.Map (Map)
22+import qualified Data.Map as Map
23+import Data.Maybe (catMaybes)
24+import Data.Set (Set)
25+import qualified Data.Set as Set
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+import Data.Traversable (for)
29+import qualified System.Directory as Directory
30+import qualified System.FilePath as FilePath
31+import Data.Coerce (Coercible, coerce)
32+
33+-- | A newtype over 'FilePath' with a phantom type parameter to allow for various tagging mechanisms.
34+newtype Path t = Path { unPath :: FilePath } deriving (Eq, Ord)
35+instance Show (Path t) where
36+ show (Path p) = show p
37+
38+-- | A 'Path' tag indicating that the path is canonical
39+data Canonical
40+
41+-- | A 'Path' tag indicating that the path is absolute
42+data Absolute
43+
44+-- | A 'Path' tag indicating that the path is relative
45+data Relative
46+
47+-- | A 'Path' tag indicating the kind of path is unknown
48+data Unknown
49+
50+class IsPath path where
51+ toFilePath :: path -> FilePath
52+
53+instance IsPath FilePath where
54+ toFilePath = id
55+
56+instance IsPath (Path t) where
57+ toFilePath = coerce
58+
59+unsafeConcatPath :: (IsPath path1, IsPath path2, Coercible FilePath path3) => path1 -> path2 -> path3
60+unsafeConcatPath a b = coerce $ toFilePath a FilePath.</> toFilePath b
61+
62+class PathConcat path1 path2 where
63+ type PathConcatResult path1 path2
64+ infixr 5 </>
65+ (</>) :: path1 -> path2 -> PathConcatResult path1 path2
66+
67+ default (</>) :: (IsPath path1, IsPath path2, Coercible FilePath (PathConcatResult path1 path2)) => path1 -> path2 -> PathConcatResult path1 path2
68+ (</>) = unsafeConcatPath
69+
70+
71+-- 'Absolute' paths on the right *always* win.
72+instance IsPath path => PathConcat path (Path Canonical) where type PathConcatResult path (Path Canonical) = Path Canonical
73+instance IsPath path => PathConcat path (Path Absolute) where type PathConcatResult path (Path Absolute) = Path Absolute
74+
75+instance PathConcat (Path Canonical) (Path Relative) where type PathConcatResult (Path Canonical) (Path Relative) = Path Absolute -- The 'Relative' path may be a symlink making the path no longer 'Canonical'
76+instance PathConcat (Path Canonical) (Path Unknown) where type PathConcatResult (Path Canonical) (Path Unknown) = Path Absolute -- 'Unknown' could be canonical, but that's just a form of being 'Absolute'
77+instance PathConcat (Path Canonical) FilePath where type PathConcatResult (Path Canonical) FilePath = PathConcatResult (Path Canonical) (Path Unknown)
78+
79+instance PathConcat (Path Absolute) (Path Relative) where type PathConcatResult (Path Absolute) (Path Relative) = Path Absolute
80+instance PathConcat (Path Absolute) (Path Unknown) where type PathConcatResult (Path Absolute) (Path Unknown) = Path Absolute -- 'Unknown' could be canonical, but that's just a form of being 'Absolute'
81+instance PathConcat (Path Absolute) FilePath where type PathConcatResult (Path Absolute) FilePath = PathConcatResult (Path Absolute) (Path Unknown)
82+
83+instance PathConcat (Path Relative) (Path Relative) where type PathConcatResult (Path Relative) (Path Relative) = Path Relative
84+instance PathConcat (Path Relative) (Path Unknown) where type PathConcatResult (Path Relative) (Path Unknown) = Path Unknown
85+instance PathConcat (Path Relative) FilePath where type PathConcatResult (Path Relative) FilePath = PathConcatResult (Path Relative) (Path Unknown)
86+
87+instance PathConcat (Path Unknown) (Path Relative) where type PathConcatResult (Path Unknown) (Path Relative) = Path Unknown
88+instance PathConcat (Path Unknown) (Path Unknown) where type PathConcatResult (Path Unknown) (Path Unknown) = Path Unknown
89+instance PathConcat (Path Unknown) FilePath where type PathConcatResult (Path Unknown) FilePath = PathConcatResult (Path Unknown) (Path Unknown)
90+
91+instance PathConcat FilePath (Path Relative) where type PathConcatResult FilePath (Path Relative) = PathConcatResult (Path Unknown) (Path Relative)
92+instance PathConcat FilePath (Path Unknown) where type PathConcatResult FilePath (Path Unknown) = PathConcatResult (Path Unknown) (Path Unknown)
93+instance PathConcat FilePath FilePath where type PathConcatResult FilePath FilePath = FilePath
94+
95+
96+
97+mkPath :: FilePath -> Path Unknown
98+mkPath = coerce
99+
100+rel :: FilePath -> Path Relative
101+rel = coerce
102+
103+canonicalizePath :: (MonadIO m, IsPath path) => path -> m (Path Canonical)
104+canonicalizePath p = liftIO $ Path <$> Directory.canonicalizePath (toFilePath p)
105+
106+makeAbsolute :: (MonadIO m, IsPath path) => path -> m (Path Absolute)
107+makeAbsolute p = liftIO $ Path <$> Directory.makeAbsolute (toFilePath p)
108+
109+listDirectory :: (MonadIO m, IsPath path) => path -> m [Path Relative]
110+listDirectory p = liftIO $ coerce <$> Directory.listDirectory (toFilePath p)
111+
112+splitDirectories :: IsPath path => path -> [String]
113+splitDirectories p = FilePath.splitDirectories (toFilePath p)
114+
115+splitPath :: IsPath path => path -> [String]
116+splitPath p = FilePath.splitPath (toFilePath p)
117+
118+createDirectoryIfMissing :: (MonadIO m, IsPath path) => Bool -> path -> m ()
119+createDirectoryIfMissing makeParents p = liftIO $ Directory.createDirectoryIfMissing makeParents (toFilePath p)
120+
121+doesDirectoryExist :: (MonadIO m, IsPath path) => path -> m Bool
122+doesDirectoryExist p = liftIO $ Directory.doesDirectoryExist (toFilePath p)
123+
124+doesFileExist :: (MonadIO m, IsPath path) => path -> m Bool
125+doesFileExist p = liftIO $ Directory.doesFileExist (toFilePath p)
126+
127+takeDirectory :: Path t -> Path t
128+takeDirectory (Path p) = Path $ FilePath.takeDirectory p
129+
130+takeFileName :: IsPath path => path -> Path Relative
131+takeFileName p = Path $ FilePath.takeFileName (toFilePath p)
132+
133+takeBaseName :: IsPath path => path -> String
134+takeBaseName p = FilePath.takeBaseName (toFilePath p)
135+
136+takeExtension :: IsPath path => path -> String
137+takeExtension p = FilePath.takeExtension (toFilePath p)
138+
139+makeRelative :: (IsPath path1, IsPath path2) => path1 -> path2 -> FilePath
140+makeRelative a b = FilePath.makeRelative (toFilePath a) (toFilePath b)
141+
142+data FindMatch a = FindMatch_SkipTree | FindMatch_SearchTree | FindMatch_Match a
143+
144+-- | Like @find@ utility but in Haskell. Note that it follows symlinks!
145+findFiles'
146+ :: forall a path m. (MonadIO m, Monoid a, IsPath path)
147+ => (FilePath -> Path Canonical -> m (FindMatch a)) -- ^ Decide how to handle an encountered path.
148+ -> path -- ^ Root path to start searching
149+ -> m a -- ^ Matches
150+findFiles' match root = go mempty (mkPath $ toFilePath root)
151+ where
152+ go :: Set (Path Canonical) -> Path Unknown -> m a
153+ go visited path = do
154+ canonicalPath <- canonicalizePath path
155+ if canonicalPath `Set.member` visited
156+ then pure mempty
157+ else match (toFilePath path) canonicalPath >>= \case
158+ FindMatch_SkipTree -> pure mempty
159+ FindMatch_Match x -> pure x
160+ FindMatch_SearchTree -> do
161+ contents <- liftIO $ listDirectory canonicalPath `catch` \(_ :: IOException) -> pure []
162+ let visited' = Set.insert canonicalPath visited
163+ fmap fold $ for contents $ \p -> go visited' (path </> p)
164+
165+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
166+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
167+zipDefaultWith _da _db _f [] [] = []
168+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
169+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
170+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
171+
172+-- | Makes the first absolute path relative to the second absolute path.
173+--
174+-- Both input paths MUST be canonical.
175+--
176+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
177+-- enough @..@ paths to make the resulting path truly relative in virtually every
178+-- case. The only exception is on Windows when the two paths are on different
179+-- drives. In this case the resulting path may be absolute.
180+relativeTo :: Path Canonical -> Path Canonical -> Path Relative -- TODO: CPP this on Windows to make it Unknown
181+relativeTo dir base
182+ = rel
183+ $ bifoldr1 (</>)
184+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
185+ $ unzip
186+ $ dropWhile (uncurry (==))
187+ $ zipDefaultWith Nothing Nothing (,)
188+ (map Just $ splitDirectories base)
189+ (map Just $ splitDirectories dir)
190+ where collapse = foldr (FilePath.</>) ""
191+
192+
193+-- | Analogous to 'Map' 'FilePath' @a@ but unifies prefixes with an inductive tree structure.
194+data PathTree a = PathTree_Node
195+ (Maybe a) -- An optional leaf at this point in the tree
196+ (Map FilePath (PathTree a)) -- Branches to deeper leaves
197+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
198+
199+instance Semigroup a => Semigroup (PathTree a) where
200+ (PathTree_Node ax x) <> (PathTree_Node ay y) = PathTree_Node (ax <> ay) $ Map.unionWith (<>) x y
201+
202+instance Semigroup a => Monoid (PathTree a) where
203+ mempty = PathTree_Node mempty mempty
204+ mappend = (<>)
205+
206+-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
207+drawPathTree :: (a -> Text) -> PathTree a -> Text
208+drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
209+ where
210+ annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
211+ goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
212+ goForest [] = []
213+ goForest [tree] = shift "└─ " " " (goTree tree)
214+ goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
215+ shift first other = zipWith (<>) (first : repeat other)
216+
217+-- | Convert a 'FilePath' into a 'PathTree'.
218+pathToTree :: IsPath path => a -> path -> PathTree a
219+pathToTree a p = go $ splitDirectories p
220+ where
221+ go [] = PathTree_Node (Just a) mempty
222+ go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
lib/command/src/Obelisk/Command/Run.hs+39−36
@@ -20,12 +20,12 @@ import Data.Default (def)
2020import Data.Either (partitionEithers)
2121import Data.Foldable (fold, for_, toList)
2222import Data.Functor ((<&>))
23−import Data.Functor.Identity (runIdentity)
2423import Data.List.NonEmpty (NonEmpty)
2524import qualified Data.List.NonEmpty as NE
2625import Data.Map (Map)
2726import qualified Data.Map as Map
2827import Data.Maybe
28+import Data.Semigroup (Last (..))
2929import Data.Set (Set)
3030import qualified Data.Set as Set
3131import Data.String.Here.Interpolated (i)
@@ -73,6 +73,9 @@ import Obelisk.Command.Project (findProjectAssets, nixShellWithoutPkgs, obeliskD
7373import Obelisk.Command.Thunk (attrCacheFileName)
7474import Obelisk.Command.Utils (ghcidExePath)
7575
76+hpackFileName :: Path Relative
77+hpackFileName = rel Hpack.packageConfig
78+
7679data CabalPackageInfo = CabalPackageInfo
7780 { _cabalPackageInfo_packageFile :: FilePath
7881 , _cabalPackageInfo_packageName :: T.Text
@@ -121,10 +124,10 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
121124 putLog Debug $ "Assets impurely loaded from: " <> assets
122125 time <- liftIO getCurrentTime
123126 let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
124− createDirectoryIfMissing True $ takeDirectory $ Path $ root </> profileBaseName
127+ createDirectoryIfMissing True $ takeDirectory $ mkPath root </> rel profileBaseName
125128 putLog Debug [i|Storing profiled data under base name of ${root </> profileBaseName}|]
126129 freePort <- getFreePort
127− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> rel "bin" </> rel "ob-run") $
130+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (toFilePath $ outPath </> rel "bin" </> rel "ob-run") $
128131 [ show freePort
129132 , T.unpack assets
130133 , profileBaseName
@@ -134,7 +137,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
134137 <> [ "-RTS" ]
135138 void $ waitForProcess ph
136139
137−run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
140+run :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
138141run root interpretPaths = do
139142 pkgs <- getParsedLocalPkgs root interpretPaths
140143 withGhciScript pkgs $ \dotGhciPath -> do
@@ -150,32 +153,32 @@ run root interpretPaths = do
150153 , "Frontend.frontend"
151154 ]
152155
153−runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
156+runRepl :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
154157runRepl root interpretPaths = do
155158 pkgs <- getParsedLocalPkgs root interpretPaths
156− ghciArgs <- getGhciSessionSettings pkgs (rel ".") True
159+ ghciArgs <- getGhciSessionSettings pkgs (mkPath ".") True
157160 withGhciScript pkgs $ \dotGhciPath ->
158161 runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
159162
160−runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163+runWatch :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
161164runWatch root interpretPaths = do
162165 pkgs <- getParsedLocalPkgs root interpretPaths
163166 ghciArgs <- getGhciSessionSettings pkgs root True
164167 withGhciScript pkgs $ \dotGhciPath ->
165168 runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
166169
167−exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
170+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> Map (Path Canonical) Interpret -> m [String]
168171exportGhciConfig useRelativePaths root interpretPaths = do
169172 pkgs <- getParsedLocalPkgs root interpretPaths
170173 getGhciSessionSettings pkgs (rel ".") useRelativePaths
171174
172−nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
175+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> Map (Path Canonical) Interpret -> Maybe String -> m ()
173176nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
174177 pkgs <- getParsedLocalPkgs root interpretPaths
175178 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
176179
177180-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
178−getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
181+getParsedLocalPkgs :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (NonEmpty CabalPackageInfo)
179182getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
180183
181184-- | Relative paths to local packages of an obelisk project.
@@ -183,15 +186,16 @@ getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs ro
183186-- These are a combination of the obelisk predefined local packages,
184187-- and any packages that the user has set with the @packages@ argument
185188-- to the Nix @project@ function.
186−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set (Path Canonical))
189+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (Set (Path Canonical))
187190getLocalPkgs root interpretPaths = do
188− putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
191+ let pathTree :: PathTree Interpret = coerce $ foldMap (\(p, x) -> pathToTree (Last x) p) $ Map.toList interpretPaths
192+ putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret pathTree
189193
190194 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
191195 -- obelisk project is our own.
192196 canonicalRoot <- canonicalizePath root
193197 obeliskPackageExclusions <- findFiles'
194− (\_ p -> if takeFileName p == Path obeliskDirName && p /= canonicalRoot
198+ (\_ p -> if takeFileName p == rel obeliskDirName && p /= canonicalRoot
195199 then liftIO (doesDirectoryExist p) <&> \case
196200 True -> FindMatch_Match $ Set.singleton p
197201 False -> FindMatch_SearchTree
@@ -199,18 +203,16 @@ getLocalPkgs root interpretPaths = do
199203 )
200204 root
201205
202− putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ map show $ Set.toList obeliskPackageExclusions}|]
203−
204206 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+ findRoots = Map.keysSet $ Map.filter (== Interpret_Interpret) interpretPaths
208+ exclusions = Map.keysSet $ Map.filter (== Interpret_NoInterpret) interpretPaths
209+ <> Map.fromSet (const Interpret_NoInterpret) obeliskPackageExclusions -- Add these last because we want left side to override
207210
208211 fmap fold $ for (toList findRoots) $ \interpretPathRoot -> do
209− let allExclusions = obeliskPackageExclusions <> exclusions
210212 findFiles'
211213 (\_ 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+ _ | p `Set.member` exclusions || attrCacheFileName `elem` splitDirectories p -> FindMatch_SkipTree
215+ | takeExtension p == ".cabal" || takeFileName p == hpackFileName -> FindMatch_Match $ Set.singleton p
214216 | otherwise -> FindMatch_SearchTree
215217 )
216218 interpretPathRoot
@@ -227,21 +229,21 @@ guessCabalPackageFile
227229 :: (MonadIO m, IsPath path)
228230 => path -- ^ Directory or path to search for cabal package
229231 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
230−guessCabalPackageFile (coerce -> pkg) = do
232+guessCabalPackageFile (toFilePath -> pkg) = do
231233 liftIO (doesDirectoryExist pkg) >>= \case
232234 False -> case cabalOrHpackFile pkg of
233235 (Just hpack@(Right _)) -> pure $ Right hpack
234236 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
235237 -- If the cabal file has a sibling hpack file, we use that instead
236238 -- since running hpack often generates a sibling cabal file
237− let possibleHpackSibling = takeDirectory (Path cabalFilePath) </> Hpack.packageConfig
239+ let possibleHpackSibling = takeDirectory $ mkPath cabalFilePath </> hpackFileName
238240 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
239− pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
241+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath $ toFilePath possibleHpackSibling) else cabal
240242 Nothing -> pure $ Left GuessPackageFileError_NotFound
241243 True -> do
242244 candidates <- liftIO $
243245 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
244− =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
246+ =<< mapMaybe (cabalOrHpackFile . toFilePath . (pkg </>)) <$> listDirectory pkg
245247 pure $ case partitionEithers candidates of
246248 ([hpack], _) -> Right $ Left hpack
247249 ([], [cabal]) -> Right $ Right cabal
@@ -251,7 +253,7 @@ guessCabalPackageFile (coerce -> pkg) = do
251253cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
252254cabalOrHpackFile = \case
253255 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
254− | takeFileName x == rel Hpack.packageConfig -> Just (Right $ HPackFilePath x)
256+ | takeFileName x == hpackFileName -> Just (Right $ HPackFilePath x)
255257 | otherwise -> Nothing
256258
257259-- | Parses the cabal package in a given directory.
@@ -271,10 +273,10 @@ parseCabalPackage'
271273 :: (MonadIO m, IsPath path)
272274 => path -- ^ Package directory
273275 -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
274−parseCabalPackage' (coerce -> pkg) = runExceptT $ do
276+parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do
275277 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
276− Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
277− Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
278+ Left GuessPackageFileError_NotFound -> throwError [i|No .cabal or package.yaml file found in ${pkg}|]
279+ Left (GuessPackageFileError_Ambiguous _) -> throwError [i|Unable to determine which .cabal file to use in ${pkg}|]
278280 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
279281 Right (Right (HPackFilePath file)) -> do
280282 let
@@ -301,7 +303,7 @@ parseCabalPackage' (coerce -> pkg) = runExceptT $ do
301303 pure $ (warnings,) $ CabalPackageInfo
302304 { _cabalPackageInfo_packageName = T.pack packageName
303305 , _cabalPackageInfo_packageFile = packageFile
304− , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (Path packageFile)
306+ , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (mkPath packageFile)
305307 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
306308 , _cabalPackageInfo_sourceDirs =
307309 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
@@ -340,11 +342,11 @@ parsePackagesOrFail dirs' = do
340342
341343 packageInfos <- case NE.nonEmpty $ toList unambiguous of
342344 Nothing -> failWith $ T.pack $
343− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (coerce dirs))
345+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (map toFilePath dirs))
344346 Just xs -> pure xs
345347
346348 unless (null pkgDirErrs) $
347− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (coerce pkgDirErrs)
349+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (map toFilePath pkgDirErrs)
348350
349351 pure packageInfos
350352 where
@@ -361,7 +363,7 @@ withGhciScript
361363 -> m ()
362364withGhciScript (toList -> packageInfos) f =
363365 withSystemTempDirectory "ob-ghci" $ \fp -> do
364− let dotGhciPath = fp </> rel ".ghci"
366+ let dotGhciPath = toFilePath $ fp </> rel ".ghci"
365367 liftIO $ writeFile dotGhciPath dotGhci
366368 f dotGhciPath
367369 where
@@ -400,11 +402,12 @@ getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
400402
401403 pure
402404 $ baseGhciOptions
403− <> ["-F", "-pgmF", unPath selfExe, "-optF", preprocessorIdentifier]
405+ <> ["-F", "-pgmF", toFilePath selfExe, "-optF", preprocessorIdentifier]
404406 <> concatMap (\p -> ["-optF", p]) pkgFiles
405407 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
406408 where
407− relativeTo' = if useRelativePaths then relativeTo else const . unPath
409+ relativeTo' :: Path Canonical -> Path Canonical -> FilePath
410+ relativeTo' a b = if useRelativePaths then toFilePath $ relativeTo a b else toFilePath a
408411
409412baseGhciOptions :: [String]
410413baseGhciOptions =
@@ -449,11 +452,11 @@ runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
449452 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
450453
451454 adjustRoot x = if chdirToRoot then makeRelative root x else x
452− reloadFiles = map adjustRoot [root </> rel "config"]
455+ reloadFiles = map adjustRoot [toFilePath $ root </> rel "config"]
453456 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
454457
455458mkGhciScriptArg :: IsPath path => path -> [String]
456−mkGhciScriptArg dotGhci = ["-ghci-script", coerce dotGhci]
459+mkGhciScriptArg dotGhci = ["-ghci-script", toFilePath dotGhci]
457460
458461getFreePort :: MonadIO m => m PortNumber
459462getFreePort = liftIO $ withSocketsDo $ do