master...3369736 · obelisk

git.iko.soy/obelisk

6 files changed+320−178

since splitsnapshots

unifiedsplit

lib/command/obelisk-command.cabal+1−1 lib/command/src/Obelisk/Command.hs+10−27 lib/command/src/Obelisk/Command/Path.hs+12 lib/command/src/Obelisk/Command/Path/Internal.hs+222 lib/command/src/Obelisk/Command/Run.hs+75−147 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+10−27

@@ -6,12 +6,13 @@

66{-# LANGUAGE TupleSections #-}

77module Obelisk.Command where

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)

1516import qualified Data.Map as Map

1617import qualified Data.Text as T

1718import Data.Traversable (for)

@@ -27,6 +28,8 @@ import System.Posix.Process (executeFile)

2728import Obelisk.App

2829import Obelisk.CliApp

2930import Obelisk.Command.Deploy

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,22 +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 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

lib/command/src/Obelisk/Command/Path.hsnew file+12

@@ -0,0 +1,12 @@

1+-- | An extremely low-ambition version of an opaque 'Path' library.

2+-- Libraries exist with much stronger guarantees but few (if any) of them

3+-- capture the idea of "canonical" paths in the types, which is critical

4+-- to many algorithms. Also the "buy-in" necessary for these approaches

5+-- is very high. This module provides the a minimal amount of type-level

6+-- tagging to allow the programmer to keep tabs on what's going on with

7+-- paths while also adding very little friction to interact with

8+-- 'FilePath'-based standard tools.

9+module Obelisk.Command.Path (module Reexport) where

10+

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+75−147

@@ -1,6 +1,3 @@

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

41{-# LANGUAGE FlexibleContexts #-}

52{-# LANGUAGE LambdaCase #-}

63{-# LANGUAGE MultiParamTypeClasses #-}

@@ -18,19 +15,17 @@ 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)

27−import Data.Functor.Identity (runIdentity)

22+import Data.Functor ((<&>))

2823import Data.List.NonEmpty (NonEmpty)

2924import qualified Data.List.NonEmpty as NE

3025import Data.Map (Map)

3126import qualified Data.Map as Map

32−import qualified Data.Map.Monoidal as MMap

3327import Data.Maybe

28+import Data.Semigroup (Last (..))

3429import Data.Set (Set)

3530import qualified Data.Set as Set

3631import Data.String.Here.Interpolated (i)

@@ -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,13 @@ 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)

75+

76+hpackFileName :: Path Relative

77+hpackFileName = rel Hpack.packageConfig

8278

8379data CabalPackageInfo = CabalPackageInfo

8480 { _cabalPackageInfo_packageFile :: FilePath

@@ -103,26 +99,6 @@ textInterpret = \case

10399 Interpret_Interpret -> "Interpret"

104100 Interpret_NoInterpret -> "NoInterpret"

105101

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−

126102-- | Used to signal to obelisk that it's being invoked as a preprocessor

127103preprocessorIdentifier :: String

128104preprocessorIdentifier = "__preprocessor-apply-packages"

@@ -148,10 +124,10 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do

148124 putLog Debug $ "Assets impurely loaded from: " <> assets

149125 time <- liftIO getCurrentTime

150126 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)

127+ createDirectoryIfMissing True $ takeDirectory $ mkPath root </> rel profileBaseName

128+ putLog Debug [i|Storing profiled data under base name of ${root </> profileBaseName}|]

153129 freePort <- getFreePort

154− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $

130+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (toFilePath $ outPath </> rel "bin" </> rel "ob-run") $

155131 [ show freePort

156132 , T.unpack assets

157133 , profileBaseName

@@ -161,7 +137,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do

161137 <> [ "-RTS" ]

162138 void $ waitForProcess ph

163139

164−run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

140+run :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()

165141run root interpretPaths = do

166142 pkgs <- getParsedLocalPkgs root interpretPaths

167143 withGhciScript pkgs $ \dotGhciPath -> do

@@ -177,32 +153,32 @@ run root interpretPaths = do

177153 , "Frontend.frontend"

178154 ]

179155

180−runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

156+runRepl :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()

181157runRepl root interpretPaths = do

182158 pkgs <- getParsedLocalPkgs root interpretPaths

183− ghciArgs <- getGhciSessionSettings pkgs "." True

159+ ghciArgs <- getGhciSessionSettings pkgs (mkPath ".") True

184160 withGhciScript pkgs $ \dotGhciPath ->

185161 runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)

186162

187−runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

163+runWatch :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()

188164runWatch root interpretPaths = do

189165 pkgs <- getParsedLocalPkgs root interpretPaths

190166 ghciArgs <- getGhciSessionSettings pkgs root True

191167 withGhciScript pkgs $ \dotGhciPath ->

192168 runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing

193169

194−exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]

170+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> Map (Path Canonical) Interpret -> m [String]

195171exportGhciConfig useRelativePaths root interpretPaths = do

196172 pkgs <- getParsedLocalPkgs root interpretPaths

197− getGhciSessionSettings pkgs "." useRelativePaths

173+ getGhciSessionSettings pkgs (rel ".") useRelativePaths

198174

199−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 ()

200176nixShellForInterpretPaths isPure shell root interpretPaths cmd = do

201177 pkgs <- getParsedLocalPkgs root interpretPaths

202178 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd

203179

204180-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.

205−getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)

181+getParsedLocalPkgs :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (NonEmpty CabalPackageInfo)

206182getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths

207183

208184-- | Relative paths to local packages of an obelisk project.

@@ -210,53 +186,36 @@ getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs ro

210186-- These are a combination of the obelisk predefined local packages,

211187-- and any packages that the user has set with the @packages@ argument

212188-- to the Nix @project@ function.

213−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)

189+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (Set (Path Canonical))

214190getLocalPkgs root interpretPaths = do

215− putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths

216− obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]

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

217193

218194 -- We do not want to find packages that are embedded inside other obelisk projects, unless that

219195 -- 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

196+ canonicalRoot <- canonicalizePath root

197+ obeliskPackageExclusions <- findFiles'

198+ (\_ p -> if takeFileName p == rel obeliskDirName && p /= canonicalRoot

199+ then liftIO (doesDirectoryExist p) <&> \case

200+ True -> FindMatch_Match $ Set.singleton p

201+ False -> FindMatch_SearchTree

202+ else pure FindMatch_SearchTree

203+ )

204+ root

205+

206+ let

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

210+

211+ fmap fold $ for (toList findRoots) $ \interpretPathRoot -> do

212+ findFiles'

213+ (\_ p -> pure $ case () of

214+ _ | p `Set.member` exclusions || attrCacheFileName `elem` splitDirectories p -> FindMatch_SkipTree

215+ | takeExtension p == ".cabal" || takeFileName p == hpackFileName -> FindMatch_Match $ Set.singleton p

216+ | otherwise -> FindMatch_SearchTree

217+ )

218+ interpretPathRoot

260219

261220data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound

262221 deriving (Eq, Ord, Show)

@@ -267,24 +226,24 @@ newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (

267226

268227-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.

269228guessCabalPackageFile

270− :: (MonadIO m)

271− => FilePath -- ^ Directory or path to search for cabal package

229+ :: (MonadIO m, IsPath path)

230+ => path -- ^ Directory or path to search for cabal package

272231 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))

273−guessCabalPackageFile pkg = do

232+guessCabalPackageFile (toFilePath -> pkg) = do

274233 liftIO (doesDirectoryExist pkg) >>= \case

275234 False -> case cabalOrHpackFile pkg of

276235 (Just hpack@(Right _)) -> pure $ Right hpack

277236 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do

278237 -- If the cabal file has a sibling hpack file, we use that instead

279238 -- since running hpack often generates a sibling cabal file

280− let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig

239+ let possibleHpackSibling = takeDirectory $ mkPath cabalFilePath </> hpackFileName

281240 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling

282− pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal

241+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath $ toFilePath possibleHpackSibling) else cabal

283242 Nothing -> pure $ Left GuessPackageFileError_NotFound

284243 True -> do

285244 candidates <- liftIO $

286245 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)

287− =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg

246+ =<< mapMaybe (cabalOrHpackFile . toFilePath . (pkg </>)) <$> listDirectory pkg

288247 pure $ case partitionEithers candidates of

289248 ([hpack], _) -> Right $ Left hpack

290249 ([], [cabal]) -> Right $ Right cabal

@@ -294,14 +253,14 @@ guessCabalPackageFile pkg = do

294253cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)

295254cabalOrHpackFile = \case

296255 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)

297− | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)

256+ | takeFileName x == hpackFileName -> Just (Right $ HPackFilePath x)

298257 | otherwise -> Nothing

299258

300259-- | Parses the cabal package in a given directory.

301260-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.

302261parseCabalPackage

303− :: MonadObelisk m

304− => FilePath -- ^ Package directory

262+ :: (MonadObelisk m, IsPath path)

263+ => path

305264 -> m (Maybe CabalPackageInfo)

306265parseCabalPackage dir = parseCabalPackage' dir >>= \case

307266 Left err -> Nothing <$ putLog Error err

@@ -311,13 +270,13 @@ parseCabalPackage dir = parseCabalPackage' dir >>= \case

311270

312271-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.

313272parseCabalPackage'

314− :: (MonadIO m)

315− => FilePath -- ^ Package directory

273+ :: (MonadIO m, IsPath path)

274+ => path -- ^ Package directory

316275 -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))

317−parseCabalPackage' pkg = runExceptT $ do

276+parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do

318277 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case

319− Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg

320− 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}|]

321280 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)

322281 Right (Right (HPackFilePath file)) -> do

323282 let

@@ -344,7 +303,7 @@ parseCabalPackage' pkg = runExceptT $ do

344303 pure $ (warnings,) $ CabalPackageInfo

345304 { _cabalPackageInfo_packageName = T.pack packageName

346305 , _cabalPackageInfo_packageFile = packageFile

347− , _cabalPackageInfo_packageRoot = takeDirectory packageFile

306+ , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (mkPath packageFile)

348307 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib

349308 , _cabalPackageInfo_sourceDirs =

350309 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

@@ -356,9 +315,9 @@ parseCabalPackage' pkg = runExceptT $ do

356315 }

357316 Right Nothing -> throwError "Haskell package has no library component"

358317 Left (_, errors) ->

359− throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)

318+ throwError $ [i|Failed to parse ${packageFile}:|] <> "\n" <> T.pack (unlines (map show errors))

360319

361−parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)

320+parsePackagesOrFail :: (MonadObelisk m, Foldable f, IsPath path) => f path -> m (NE.NonEmpty CabalPackageInfo)

362321parsePackagesOrFail dirs' = do

363322 (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do

364323 flip fmap (parseCabalPackage dir) $ \case

@@ -383,11 +342,11 @@ parsePackagesOrFail dirs' = do

383342

384343 packageInfos <- case NE.nonEmpty $ toList unambiguous of

385344 Nothing -> failWith $ T.pack $

386− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)

345+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (map toFilePath dirs))

387346 Just xs -> pure xs

388347

389348 unless (null pkgDirErrs) $

390− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs

349+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (map toFilePath pkgDirErrs)

391350

392351 pure packageInfos

393352 where

@@ -404,7 +363,7 @@ withGhciScript

404363 -> m ()

405364withGhciScript (toList -> packageInfos) f =

406365 withSystemTempDirectory "ob-ghci" $ \fp -> do

407− let dotGhciPath = fp </> ".ghci"

366+ let dotGhciPath = toFilePath $ fp </> rel ".ghci"

408367 liftIO $ writeFile dotGhciPath dotGhci

409368 f dotGhciPath

410369 where

@@ -424,17 +383,17 @@ withGhciScript (toList -> packageInfos) f =

424383-- | Builds a list of options to pass to ghci or set in .ghci file that configures

425384-- the preprocessor and source includes.

426385getGhciSessionSettings

427− :: (MonadObelisk m, Foldable f)

386+ :: (MonadObelisk m, Foldable f, IsPath path)

428387 => f CabalPackageInfo -- ^ List of packages to load into ghci

429− -> FilePath -- ^ All paths will be relative to this path

388+ -> path -- ^ All paths will be relative to this path

430389 -> Bool -- ^ Use relative paths

431390 -> m [String]

432391getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do

433392 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that

434393 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize

435394 -- all paths to 'pathBase'.

436− selfExe <- liftIO $ canonicalizePath =<< getExecutablePath

437− canonicalPathBase <- liftIO $ canonicalizePath pathBase

395+ selfExe <- canonicalizePath =<< liftIO getExecutablePath

396+ canonicalPathBase <- canonicalizePath pathBase

438397

439398 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do

440399 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg

@@ -443,11 +402,12 @@ getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do

443402

444403 pure

445404 $ baseGhciOptions

446− <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]

405+ <> ["-F", "-pgmF", toFilePath selfExe, "-optF", preprocessorIdentifier]

447406 <> concatMap (\p -> ["-optF", p]) pkgFiles

448407 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]

449408 where

450− relativeTo' = if useRelativePaths then relativeTo else const

409+ relativeTo' :: Path Canonical -> Path Canonical -> FilePath

410+ relativeTo' a b = if useRelativePaths then toFilePath $ relativeTo a b else toFilePath a

451411

452412baseGhciOptions :: [String]

453413baseGhciOptions =

@@ -492,11 +452,11 @@ runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =

492452 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape

493453

494454 adjustRoot x = if chdirToRoot then makeRelative root x else x

495− reloadFiles = map adjustRoot [root </> "config"]

455+ reloadFiles = map adjustRoot [toFilePath $ root </> rel "config"]

496456 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages

497457

498−mkGhciScriptArg :: FilePath -> [String]

499−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]

458+mkGhciScriptArg :: IsPath path => path -> [String]

459+mkGhciScriptArg dotGhci = ["-ghci-script", toFilePath dotGhci]

500460

501461getFreePort :: MonadIO m => m PortNumber

502462getFreePort = liftIO $ withSocketsDo $ do

@@ -509,35 +469,3 @@ getFreePort = liftIO $ withSocketsDo $ do

509469 return sock

510470

511471

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