module Proteome.Project.Resolve where

import Control.Monad (foldM)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
import Data.List (nub)
import Data.List.Extra (firstJust)
import Data.Map.Strict ((!?))
import qualified Data.Map.Strict as Map (toList, union)
import Exon (exon)
import qualified Log
import Path (Abs, Dir, Path, dirname, isProperPrefixOf, parent, parseRelDir, stripProperPrefix, toFilePath, (</>))
import Path.IO (doesDirExist)
import Ribosome (Settings)
import qualified Ribosome.Settings as Settings
import System.FilePath.Glob (globDir1)
import qualified System.FilePath.Glob as Glob (compile)
import System.FilePattern.Directory (getDirectoryFiles)

import Proteome.Config (defaultTypeMarkers)
import Proteome.Data.Project (Project (Project))
import qualified Proteome.Data.ProjectConfig as ProjectConfig
import Proteome.Data.ProjectConfig (ProjectConfig (ProjectConfig))
import Proteome.Data.ProjectLang (ProjectLang (ProjectLang))
import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject))
import Proteome.Data.ProjectName (ProjectName (ProjectName))
import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot), unProjectRoot)
import Proteome.Data.ProjectSpec (ProjectSpec (ProjectSpec))
import qualified Proteome.Data.ProjectSpec as PS (ProjectSpec (..))
import Proteome.Data.ProjectType (ProjectType (ProjectType))
import qualified Proteome.Data.ResolveError as ResolveError (ResolveError (..))
import Proteome.Data.ResolveError (ResolveError)
import Proteome.Path (dropSlash, parseAbsDirMaybe, rootPathSegment)
import Proteome.Project (pathData)
import qualified Proteome.Settings as Settings (projectConfig, projects)

projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
tpe ProjectName
name ProjectRoot
root =
  ProjectMetadata
-> [ProjectType] -> Maybe ProjectLang -> [ProjectLang] -> Project
Project (ProjectName -> ProjectRoot -> Maybe ProjectType -> ProjectMetadata
DirProject ProjectName
name ProjectRoot
root (ProjectType -> Maybe ProjectType
forall a. a -> Maybe a
Just ProjectType
tpe)) [] Maybe ProjectLang
forall a. Maybe a
Nothing []

projectFromSpec :: ProjectSpec -> Project
projectFromSpec :: ProjectSpec -> Project
projectFromSpec (ProjectSpec ProjectName
name ProjectRoot
root Maybe ProjectType
tpe [ProjectType]
types Maybe ProjectLang
lang [ProjectLang]
langs) =
  ProjectMetadata
-> [ProjectType] -> Maybe ProjectLang -> [ProjectLang] -> Project
Project (ProjectName -> ProjectRoot -> Maybe ProjectType -> ProjectMetadata
DirProject ProjectName
name ProjectRoot
root Maybe ProjectType
tpe) [ProjectType]
types Maybe ProjectLang
lang [ProjectLang]
langs

hasProjectRoot :: ProjectRoot -> ProjectSpec -> Bool
hasProjectRoot :: ProjectRoot -> ProjectSpec -> Bool
hasProjectRoot ProjectRoot
root ProjectSpec
spec = ProjectRoot
root ProjectRoot -> ProjectRoot -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectSpec -> ProjectRoot
PS.root ProjectSpec
spec

hasProjectTypeName :: ProjectType -> ProjectName -> ProjectSpec -> Bool
hasProjectTypeName :: ProjectType -> ProjectName -> ProjectSpec -> Bool
hasProjectTypeName ProjectType
tpe' ProjectName
name' (ProjectSpec ProjectName
name ProjectRoot
_ (Just ProjectType
tpe) [ProjectType]
_ Maybe ProjectLang
_ [ProjectLang]
_) =
  ProjectName
name' ProjectName -> ProjectName -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectName
name Bool -> Bool -> Bool
&& ProjectType
tpe' ProjectType -> ProjectType -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectType
tpe
hasProjectTypeName ProjectType
_ ProjectName
_ ProjectSpec
_ = Bool
False

byProjectTypeName :: [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec
byProjectTypeName :: [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec
byProjectTypeName [ProjectSpec]
specs ProjectName
name ProjectType
tpe = (ProjectSpec -> Bool) -> [ProjectSpec] -> Maybe ProjectSpec
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ProjectType -> ProjectName -> ProjectSpec -> Bool
hasProjectTypeName ProjectType
tpe ProjectName
name) [ProjectSpec]
specs

matchProjectBases :: [Path Abs Dir] -> ProjectRoot -> Bool
matchProjectBases :: [Path Abs Dir] -> ProjectRoot -> Bool
matchProjectBases [Path Abs Dir]
baseDirs (ProjectRoot Path Abs Dir
root) = (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs Dir -> Path Abs Dir)
-> (Path Abs Dir -> Path Abs Dir) -> Path Abs Dir -> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent) Path Abs Dir
root Path Abs Dir -> [Path Abs Dir] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Abs Dir]
baseDirs

byProjectBaseSubpath ::
  Members [Stop ResolveError, Embed IO] r =>
  ProjectName ->
  ProjectType ->
  Path Abs Dir ->
  Sem r (Maybe Project)
byProjectBaseSubpath :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
ProjectName -> ProjectType -> Path Abs Dir -> Sem r (Maybe Project)
byProjectBaseSubpath n :: ProjectName
n@(ProjectName Text
name) t :: ProjectType
t@(ProjectType Text
tpe) Path Abs Dir
base = do
  Path Rel Dir
tpePath <- ResolveError
-> Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir)
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
err' -> Either err a -> Sem r a
stopEitherAs (Text -> ResolveError
ResolveError.ParsePath Text
tpe) (Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir))
-> Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
tpe)
  Path Rel Dir
namePath <- ResolveError
-> Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir)
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
err' -> Either err a -> Sem r a
stopEitherAs (Text -> ResolveError
ResolveError.ParsePath Text
name) (Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir))
-> Either SomeException (Path Rel Dir) -> Sem r (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
name)
  let root :: Path Abs Dir
root = Path Abs Dir
base Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
tpePath Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
namePath
  Bool
exists <- Path Abs Dir -> Sem r Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
root
  pure $ if Bool
exists then Project -> Maybe Project
forall a. a -> Maybe a
Just (Project -> Maybe Project) -> Project -> Maybe Project
forall a b. (a -> b) -> a -> b
$ ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
t ProjectName
n (Path Abs Dir -> ProjectRoot
ProjectRoot Path Abs Dir
root) else Maybe Project
forall a. Maybe a
Nothing

byProjectBasesSubpath ::
  Members [Stop ResolveError, Embed IO] r =>
  [Path Abs Dir] ->
  ProjectName ->
  ProjectType ->
  Sem r (Maybe Project)
byProjectBasesSubpath :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir]
-> ProjectName -> ProjectType -> Sem r (Maybe Project)
byProjectBasesSubpath [Path Abs Dir]
baseDirs ProjectName
name ProjectType
tpe =
  (Maybe Project -> Path Abs Dir -> Sem r (Maybe Project))
-> Maybe Project -> [Path Abs Dir] -> Sem r (Maybe Project)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe Project -> Path Abs Dir -> Sem r (Maybe Project)
subpath Maybe Project
forall a. Maybe a
Nothing [Path Abs Dir]
baseDirs
  where
    subpath :: Maybe Project -> Path Abs Dir -> Sem r (Maybe Project)
subpath (Just Project
p) Path Abs Dir
_ = Maybe Project -> Sem r (Maybe Project)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project -> Maybe Project
forall a. a -> Maybe a
Just Project
p)
    subpath Maybe Project
Nothing Path Abs Dir
a = ProjectName -> ProjectType -> Path Abs Dir -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
ProjectName -> ProjectType -> Path Abs Dir -> Sem r (Maybe Project)
byProjectBaseSubpath ProjectName
name ProjectType
tpe Path Abs Dir
a

virtualProject :: ProjectName -> Project
virtualProject :: ProjectName -> Project
virtualProject ProjectName
name =
  ProjectMetadata
-> [ProjectType] -> Maybe ProjectLang -> [ProjectLang] -> Project
Project (ProjectName -> ProjectMetadata
VirtualProject ProjectName
name) [] Maybe ProjectLang
forall a. Maybe a
Nothing []

resolveByTypeAndPath :: [Path Abs Dir] -> ProjectName -> ProjectType -> ProjectRoot -> Maybe Project
resolveByTypeAndPath :: [Path Abs Dir]
-> ProjectName -> ProjectType -> ProjectRoot -> Maybe Project
resolveByTypeAndPath [Path Abs Dir]
baseDirs ProjectName
name ProjectType
tpe ProjectRoot
root =
  if [Path Abs Dir] -> ProjectRoot -> Bool
matchProjectBases [Path Abs Dir]
baseDirs ProjectRoot
root then Project -> Maybe Project
forall a. a -> Maybe a
Just (ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
tpe ProjectName
name ProjectRoot
root) else Maybe Project
forall a. Maybe a
Nothing

resolveByType ::
  Members [Stop ResolveError, Embed IO] r =>
  [Path Abs Dir] ->
  [ProjectSpec] ->
  ProjectName ->
  ProjectType ->
  Sem r (Maybe Project)
resolveByType :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir]
-> [ProjectSpec]
-> ProjectName
-> ProjectType
-> Sem r (Maybe Project)
resolveByType [Path Abs Dir]
baseDirs [ProjectSpec]
explicit ProjectName
name ProjectType
tpe = do
  Maybe Project
byBaseSubpath <- [Path Abs Dir]
-> ProjectName -> ProjectType -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir]
-> ProjectName -> ProjectType -> Sem r (Maybe Project)
byProjectBasesSubpath [Path Abs Dir]
baseDirs ProjectName
name ProjectType
tpe
  pure (Maybe Project
byBaseSubpath Maybe Project -> Maybe Project -> Maybe Project
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ProjectSpec -> Project
projectFromSpec (ProjectSpec -> Project) -> Maybe ProjectSpec -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ProjectSpec
byTypeName)
  where
    byTypeName :: Maybe ProjectSpec
byTypeName =
      [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec
byProjectTypeName [ProjectSpec]
explicit ProjectName
name ProjectType
tpe

fromProjectRoot :: Path Abs Dir -> Project
fromProjectRoot :: Path Abs Dir -> Project
fromProjectRoot Path Abs Dir
dir =
  ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
tpe ProjectName
name ProjectRoot
root
  where
    (ProjectRoot
root, ProjectName
name, ProjectType
tpe) = Path Abs Dir -> (ProjectRoot, ProjectName, ProjectType)
pathData Path Abs Dir
dir

projectFromNameIn ::
  Members [Stop ResolveError, Embed IO] r =>
  ProjectName ->
  Path Abs Dir ->
  Sem r (Maybe Project)
projectFromNameIn :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
ProjectName -> Path Abs Dir -> Sem r (Maybe Project)
projectFromNameIn (ProjectName Text
name) Path Abs Dir
base =
  (Path Abs Dir -> Project) -> Maybe (Path Abs Dir) -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Abs Dir -> Project
fromProjectRoot (Maybe (Path Abs Dir) -> Maybe Project)
-> ([Maybe (Path Abs Dir)] -> Maybe (Path Abs Dir))
-> [Maybe (Path Abs Dir)]
-> Maybe Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe (Path Abs Dir)) -> Maybe (Path Abs Dir)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Path Abs Dir)) -> Maybe (Path Abs Dir))
-> ([Maybe (Path Abs Dir)] -> Maybe (Maybe (Path Abs Dir)))
-> [Maybe (Path Abs Dir)]
-> Maybe (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Path Abs Dir) -> Bool)
-> [Maybe (Path Abs Dir)] -> Maybe (Maybe (Path Abs Dir))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Maybe (Path Abs Dir) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (Path Abs Dir)] -> Maybe Project)
-> Sem r [Maybe (Path Abs Dir)] -> Sem r (Maybe Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r [Maybe (Path Abs Dir)]
matches
  where
    matches :: Sem r [Maybe (Path Abs Dir)]
matches =
      (FilePath -> Maybe (Path Abs Dir))
-> [FilePath] -> [Maybe (Path Abs Dir)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Maybe (Path Abs Dir)
parseAbsDirMaybe (Text -> Maybe (Path Abs Dir))
-> (FilePath -> Text) -> FilePath -> Maybe (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. ToText a => a -> Text
toText) ([FilePath] -> [Maybe (Path Abs Dir)])
-> Sem r [FilePath] -> Sem r [Maybe (Path Abs Dir)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r [FilePath]
glob
    glob :: Sem r [FilePath]
glob =
      IO [FilePath] -> Sem r [FilePath]
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO [FilePath] -> Sem r [FilePath])
-> IO [FilePath] -> Sem r [FilePath]
forall a b. (a -> b) -> a -> b
$ Pattern -> FilePath -> IO [FilePath]
globDir1 (FilePath -> Pattern
Glob.compile (FilePath
"*/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
name)) (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
base)

resolveByName ::
  Members [Stop ResolveError, Embed IO] r =>
  [Path Abs Dir] ->
  ProjectName ->
  Sem r (Maybe Project)
resolveByName :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir] -> ProjectName -> Sem r (Maybe Project)
resolveByName [Path Abs Dir]
baseDirs ProjectName
name =
  (Path Abs Dir -> Sem r (Maybe Project))
-> [Path Abs Dir] -> Sem r (Maybe Project)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM (ProjectName -> Path Abs Dir -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
ProjectName -> Path Abs Dir -> Sem r (Maybe Project)
projectFromNameIn ProjectName
name) [Path Abs Dir]
baseDirs

globDir ::
  Members [Stop ResolveError, Embed IO] r =>
  Path Abs Dir ->
  [Text] ->
  Sem r (Maybe FilePath)
globDir :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
Path Abs Dir -> [Text] -> Sem r (Maybe FilePath)
globDir Path Abs Dir
root [Text]
patterns =
  ([FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
head ([FilePath] -> Maybe FilePath)
-> Maybe [FilePath] -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe [FilePath] -> Maybe FilePath)
-> Sem r (Maybe [FilePath]) -> Sem r (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> Sem r (Maybe [FilePath])
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Maybe a)
tryMaybe (FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
root) (Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
patterns))

resolveFromDirContents ::
  Members [Stop ResolveError, Embed IO] r =>
  Map ProjectType [Text] ->
  ProjectName ->
  ProjectRoot ->
  Sem r (Maybe Project)
resolveFromDirContents :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
Map ProjectType [Text]
-> ProjectName -> ProjectRoot -> Sem r (Maybe Project)
resolveFromDirContents Map ProjectType [Text]
typeMarkers ProjectName
name projectRoot :: ProjectRoot
projectRoot@(ProjectRoot Path Abs Dir
root) =
  (ProjectType -> Project) -> Maybe ProjectType -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectType -> Project
cons (Maybe ProjectType -> Maybe Project)
-> Sem r (Maybe ProjectType) -> Sem r (Maybe Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ProjectType, [Text]) -> Sem r (Maybe ProjectType))
-> [(ProjectType, [Text])] -> Sem r (Maybe ProjectType)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM (ProjectType, [Text]) -> Sem r (Maybe ProjectType)
match (Map ProjectType [Text] -> [(ProjectType, [Text])]
forall k a. Map k a -> [(k, a)]
Map.toList Map ProjectType [Text]
typeMarkers)
  where
    cons :: ProjectType -> Project
cons ProjectType
projectType =
      ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
projectType ProjectName
name ProjectRoot
projectRoot
    match :: (ProjectType, [Text]) -> Sem r (Maybe ProjectType)
match (ProjectType
tpe, [Text]
patterns) =
      (ProjectType
tpe ProjectType -> Maybe FilePath -> Maybe ProjectType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Maybe FilePath -> Maybe ProjectType)
-> Sem r (Maybe FilePath) -> Sem r (Maybe ProjectType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> [Text] -> Sem r (Maybe FilePath)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
Path Abs Dir -> [Text] -> Sem r (Maybe FilePath)
globDir Path Abs Dir
root [Text]
patterns

resolveByRoot ::
  Members [Stop ResolveError, Embed IO] r =>
  ProjectConfig ->
  ProjectName ->
  [ProjectSpec] ->
  ProjectRoot ->
  Sem r (Maybe Project)
resolveByRoot :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
ProjectConfig
-> ProjectName
-> [ProjectSpec]
-> ProjectRoot
-> Sem r (Maybe Project)
resolveByRoot (ProjectConfig [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [ProjectType]
_ Map ProjectType [Text]
typeMarkers Map ProjectType ProjectLang
_ Map ProjectLang [ProjectLang]
_) ProjectName
name [ProjectSpec]
explicit ProjectRoot
root =
  Sem r (Maybe Project)
-> (ProjectSpec -> Sem r (Maybe Project))
-> Maybe ProjectSpec
-> Sem r (Maybe Project)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map ProjectType [Text]
-> ProjectName -> ProjectRoot -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
Map ProjectType [Text]
-> ProjectName -> ProjectRoot -> Sem r (Maybe Project)
resolveFromDirContents Map ProjectType [Text]
typeMarkers ProjectName
name ProjectRoot
root) (Maybe Project -> Sem r (Maybe Project)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Project -> Sem r (Maybe Project))
-> (ProjectSpec -> Maybe Project)
-> ProjectSpec
-> Sem r (Maybe Project)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> Maybe Project
forall a. a -> Maybe a
Just (Project -> Maybe Project)
-> (ProjectSpec -> Project) -> ProjectSpec -> Maybe Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectSpec -> Project
projectFromSpec) Maybe ProjectSpec
fromExplicit
  where
    fromExplicit :: Maybe ProjectSpec
fromExplicit = (ProjectSpec -> Bool) -> [ProjectSpec] -> Maybe ProjectSpec
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ProjectRoot -> ProjectSpec -> Bool
hasProjectRoot ProjectRoot
root) [ProjectSpec]
explicit

augment ::
  Eq a =>
  Ord k =>
  Map k [a] ->
  k ->
  [a] ->
  [a]
augment :: forall a k. (Eq a, Ord k) => Map k [a] -> k -> [a] -> [a]
augment Map k [a]
m k
tpe [a]
as =
  case Map k [a]
m Map k [a] -> k -> Maybe [a]
forall k a. Ord k => Map k a -> k -> Maybe a
!? k
tpe of
    Just [a]
extra -> [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
extra
    Maybe [a]
Nothing -> [a]
as

augmentTypes :: ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType]
augmentTypes :: ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType]
augmentTypes (ProjectConfig [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [ProjectType]
typeMap Map ProjectType [Text]
_ Map ProjectType ProjectLang
_ Map ProjectLang [ProjectLang]
_) =
  Map ProjectType [ProjectType]
-> ProjectType -> [ProjectType] -> [ProjectType]
forall a k. (Eq a, Ord k) => Map k [a] -> k -> [a] -> [a]
augment Map ProjectType [ProjectType]
typeMap

resolveLanguage :: ProjectConfig -> ProjectType -> ProjectLang
resolveLanguage :: ProjectConfig -> ProjectType -> ProjectLang
resolveLanguage (ProjectConfig [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [ProjectType]
_ Map ProjectType [Text]
_ Map ProjectType ProjectLang
langMap Map ProjectLang [ProjectLang]
_) t :: ProjectType
t@(ProjectType Text
tpe) =
  ProjectLang -> Maybe ProjectLang -> ProjectLang
forall a. a -> Maybe a -> a
fromMaybe (Text -> ProjectLang
ProjectLang Text
tpe) (Map ProjectType ProjectLang
langMap Map ProjectType ProjectLang -> ProjectType -> Maybe ProjectLang
forall k a. Ord k => Map k a -> k -> Maybe a
!? ProjectType
t)

augmentLangs :: ProjectConfig -> ProjectLang -> [ProjectLang] -> [ProjectLang]
augmentLangs :: ProjectConfig -> ProjectLang -> [ProjectLang] -> [ProjectLang]
augmentLangs (ProjectConfig [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [Path Abs Dir]
_ Map ProjectType [ProjectType]
_ Map ProjectType [Text]
_ Map ProjectType ProjectLang
_ Map ProjectLang [ProjectLang]
langsMap) =
  Map ProjectLang [ProjectLang]
-> ProjectLang -> [ProjectLang] -> [ProjectLang]
forall a k. (Eq a, Ord k) => Map k [a] -> k -> [a] -> [a]
augment Map ProjectLang [ProjectLang]
langsMap

augmentFromConfig :: ProjectConfig -> Project -> Project
augmentFromConfig :: ProjectConfig -> Project -> Project
augmentFromConfig ProjectConfig
config (Project meta :: ProjectMetadata
meta@(DirProject ProjectName
_ ProjectRoot
_ (Just ProjectType
tpe)) [ProjectType]
types Maybe ProjectLang
lang [ProjectLang]
langs) =
  ProjectMetadata
-> [ProjectType] -> Maybe ProjectLang -> [ProjectLang] -> Project
Project ProjectMetadata
meta (ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType]
augmentTypes ProjectConfig
config ProjectType
tpe [ProjectType]
types) (ProjectLang -> Maybe ProjectLang
forall a. a -> Maybe a
Just ProjectLang
lang') (ProjectConfig -> ProjectLang -> [ProjectLang] -> [ProjectLang]
augmentLangs ProjectConfig
config ProjectLang
lang' [ProjectLang]
langs)
  where
    lang' :: ProjectLang
lang' = ProjectLang -> Maybe ProjectLang -> ProjectLang
forall a. a -> Maybe a -> a
fromMaybe (ProjectConfig -> ProjectType -> ProjectLang
resolveLanguage ProjectConfig
config ProjectType
tpe) Maybe ProjectLang
lang
augmentFromConfig ProjectConfig
_ Project
project =
  Project
project

fromName ::
  Members [Stop ResolveError, Log, Embed IO] r =>
  [ProjectSpec] ->
  ProjectConfig ->
  ProjectName ->
  Maybe ProjectType ->
  Sem r Project
fromName :: forall (r :: EffectRow).
Members '[Stop ResolveError, Log, Embed IO] r =>
[ProjectSpec]
-> ProjectConfig
-> ProjectName
-> Maybe ProjectType
-> Sem r Project
fromName [ProjectSpec]
explicit ProjectConfig
config ProjectName
name Maybe ProjectType
tpe = do
  let baseDirs :: [Path Abs Dir]
baseDirs = ProjectConfig -> [Path Abs Dir]
ProjectConfig.baseDirs ProjectConfig
config
  Maybe Project
byType <- Maybe (Maybe Project) -> Maybe Project
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Project) -> Maybe Project)
-> Sem r (Maybe (Maybe Project)) -> Sem r (Maybe Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProjectType -> Sem r (Maybe Project))
-> Maybe ProjectType -> Sem r (Maybe (Maybe Project))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Path Abs Dir]
-> [ProjectSpec]
-> ProjectName
-> ProjectType
-> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir]
-> [ProjectSpec]
-> ProjectName
-> ProjectType
-> Sem r (Maybe Project)
resolveByType [Path Abs Dir]
baseDirs [ProjectSpec]
explicit ProjectName
name) Maybe ProjectType
tpe
  Maybe Project
byName <- [Path Abs Dir] -> ProjectName -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[Path Abs Dir] -> ProjectName -> Sem r (Maybe Project)
resolveByName [Path Abs Dir]
baseDirs ProjectName
name
  let byNameOrVirtual :: Project
byNameOrVirtual = Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
virtualProject ProjectName
name) Maybe Project
byName
  let project :: Project
project = Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe Project
byNameOrVirtual Maybe Project
byType
  Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug (Maybe Project -> Maybe Project -> Text
forall {inner} {builder} {a} {a}.
(ExonAppend inner builder, ExonString inner builder,
 ExonBuilder inner builder, IsString inner, Show a, Show a) =>
a -> a -> inner
logMsg Maybe Project
byType Maybe Project
byName)
  pure (ProjectConfig -> Project -> Project
augmentFromConfig ProjectConfig
config Project
project)
  where
    logMsg :: a -> a -> inner
logMsg a
byType a
byName =
      [exon|resolved project: byType(#{show byType}) byName(#{show byName})|]

fromNameSettings ::
  Members [Settings, Stop ResolveError, Log, Embed IO] r =>
  ProjectName ->
  Maybe ProjectType ->
  Sem r Project
fromNameSettings :: forall (r :: EffectRow).
Members '[Settings, Stop ResolveError, Log, Embed IO] r =>
ProjectName -> Maybe ProjectType -> Sem r Project
fromNameSettings ProjectName
name Maybe ProjectType
tpe = do
  [ProjectSpec]
explicit <- Setting [ProjectSpec] -> Sem r [ProjectSpec]
forall a (r :: EffectRow).
(MsgpackDecode a, Member Settings r) =>
Setting a -> Sem r a
Settings.get Setting [ProjectSpec]
Settings.projects
  ProjectConfig
config <- Sem r ProjectConfig
forall (r :: EffectRow). Member Settings r => Sem r ProjectConfig
projectConfig
  [ProjectSpec]
-> ProjectConfig
-> ProjectName
-> Maybe ProjectType
-> Sem r Project
forall (r :: EffectRow).
Members '[Stop ResolveError, Log, Embed IO] r =>
[ProjectSpec]
-> ProjectConfig
-> ProjectName
-> Maybe ProjectType
-> Sem r Project
fromName [ProjectSpec]
explicit ProjectConfig
config ProjectName
name Maybe ProjectType
tpe

projectConfig ::
  Member Settings r =>
  Sem r ProjectConfig
projectConfig :: forall (r :: EffectRow). Member Settings r => Sem r ProjectConfig
projectConfig =
  (IsLabel
  "typeMarkers"
  (ASetter
     ProjectConfig
     ProjectConfig
     (Map ProjectType [Text])
     (Map ProjectType [Text]))
ASetter
  ProjectConfig
  ProjectConfig
  (Map ProjectType [Text])
  (Map ProjectType [Text])
#typeMarkers ASetter
  ProjectConfig
  ProjectConfig
  (Map ProjectType [Text])
  (Map ProjectType [Text])
-> (Map ProjectType [Text] -> Map ProjectType [Text])
-> ProjectConfig
-> ProjectConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map ProjectType [Text]
-> Map ProjectType [Text] -> Map ProjectType [Text]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ProjectType [Text]
defaultTypeMarkers)) (ProjectConfig -> ProjectConfig)
-> Sem r ProjectConfig -> Sem r ProjectConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Setting ProjectConfig -> Sem r ProjectConfig
forall a (r :: EffectRow).
(MsgpackDecode a, Member Settings r) =>
Setting a -> Sem r a
Settings.get Setting ProjectConfig
Settings.projectConfig

rootExplicit :: [ProjectSpec] -> ProjectRoot -> Maybe Project
rootExplicit :: [ProjectSpec] -> ProjectRoot -> Maybe Project
rootExplicit [ProjectSpec]
explicit ProjectRoot
root =
  ProjectSpec -> Project
projectFromSpec (ProjectSpec -> Project) -> Maybe ProjectSpec -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProjectSpec -> Bool) -> [ProjectSpec] -> Maybe ProjectSpec
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ProjectRoot -> ProjectSpec -> Bool
hasProjectRoot ProjectRoot
root) [ProjectSpec]
explicit

rootProjectTypes ::
  Map ProjectType [Path Abs Dir] ->
  ProjectName ->
  ProjectRoot ->
  Maybe Project
rootProjectTypes :: Map ProjectType [Path Abs Dir]
-> ProjectName -> ProjectRoot -> Maybe Project
rootProjectTypes Map ProjectType [Path Abs Dir]
tpes ProjectName
name root :: ProjectRoot
root@(ProjectRoot Path Abs Dir
rootDir) =
  ProjectType -> Project
cons (ProjectType -> Project)
-> ((ProjectType, [Path Abs Dir]) -> ProjectType)
-> (ProjectType, [Path Abs Dir])
-> Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectType, [Path Abs Dir]) -> ProjectType
forall a b. (a, b) -> a
fst ((ProjectType, [Path Abs Dir]) -> Project)
-> Maybe (ProjectType, [Path Abs Dir]) -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ProjectType, [Path Abs Dir]) -> Bool)
-> [(ProjectType, [Path Abs Dir])]
-> Maybe (ProjectType, [Path Abs Dir])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Path Abs Dir -> [Path Abs Dir] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Path Abs Dir
rootDir ([Path Abs Dir] -> Bool)
-> ((ProjectType, [Path Abs Dir]) -> [Path Abs Dir])
-> (ProjectType, [Path Abs Dir])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectType, [Path Abs Dir]) -> [Path Abs Dir]
forall a b. (a, b) -> b
snd) (Map ProjectType [Path Abs Dir] -> [(ProjectType, [Path Abs Dir])]
forall k a. Map k a -> [(k, a)]
Map.toList Map ProjectType [Path Abs Dir]
tpes)
  where
    cons :: ProjectType -> Project
cons ProjectType
tpe =
      ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
tpe ProjectName
name ProjectRoot
root

rootTypeDirs ::
  Map ProjectType [Path Abs Dir] ->
  ProjectName ->
  ProjectRoot ->
  Maybe Project
rootTypeDirs :: Map ProjectType [Path Abs Dir]
-> ProjectName -> ProjectRoot -> Maybe Project
rootTypeDirs Map ProjectType [Path Abs Dir]
types ProjectName
name root :: ProjectRoot
root@(ProjectRoot Path Abs Dir
rootDir) =
  ProjectType -> Project
cons (ProjectType -> Project)
-> ((ProjectType, [Path Abs Dir]) -> ProjectType)
-> (ProjectType, [Path Abs Dir])
-> Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectType, [Path Abs Dir]) -> ProjectType
forall a b. (a, b) -> a
fst ((ProjectType, [Path Abs Dir]) -> Project)
-> Maybe (ProjectType, [Path Abs Dir]) -> Maybe Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ProjectType, [Path Abs Dir]) -> Bool)
-> [(ProjectType, [Path Abs Dir])]
-> Maybe (ProjectType, [Path Abs Dir])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ([Path Abs Dir] -> Bool
matchType ([Path Abs Dir] -> Bool)
-> ((ProjectType, [Path Abs Dir]) -> [Path Abs Dir])
-> (ProjectType, [Path Abs Dir])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectType, [Path Abs Dir]) -> [Path Abs Dir]
forall a b. (a, b) -> b
snd) (Map ProjectType [Path Abs Dir] -> [(ProjectType, [Path Abs Dir])]
forall k a. Map k a -> [(k, a)]
Map.toList Map ProjectType [Path Abs Dir]
types)
  where
    cons :: ProjectType -> Project
cons ProjectType
tpe =
      ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments ProjectType
tpe ProjectName
name ProjectRoot
root
    matchType :: [Path Abs Dir] -> Bool
matchType =
      (Path Abs Dir -> Bool) -> [Path Abs Dir] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Path Abs Dir -> Bool
match
    match :: Path Abs Dir -> Bool
match Path Abs Dir
base = do
      Path Abs Dir -> Path Abs Dir -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
base Path Abs Dir
rootDir

rootBaseDirs ::
  [Path Abs Dir] ->
  ProjectName ->
  ProjectRoot ->
  Maybe Project
rootBaseDirs :: [Path Abs Dir] -> ProjectName -> ProjectRoot -> Maybe Project
rootBaseDirs [Path Abs Dir]
bases ProjectName
name root :: ProjectRoot
root@(ProjectRoot Path Abs Dir
rootDir) =
  (Path Abs Dir -> Maybe Project) -> [Path Abs Dir] -> Maybe Project
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust Path Abs Dir -> Maybe Project
match [Path Abs Dir]
bases
  where
    match :: Path Abs Dir -> Maybe Project
match Path Abs Dir
base = do
      Path Rel Dir
rel <- Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
base Path Abs Dir
rootDir
      let tpe :: Path Rel Dir
tpe = Path Rel Dir -> Path Rel Dir
forall b. Path b Dir -> Path b Dir
rootPathSegment (Path Rel Dir -> Path Rel Dir
forall b t. Path b t -> Path b Dir
parent Path Rel Dir
rel)
      if Path Rel Dir
rel Path Rel Dir -> Path Rel Dir -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Rel Dir
tpe
      then Project -> Maybe Project
forall a. a -> Maybe a
Just (ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments (Text -> ProjectType
ProjectType (Path Rel Dir -> Text
forall b t. Path b t -> Text
dropSlash Path Rel Dir
tpe)) ProjectName
name ProjectRoot
root)
      else Maybe Project
forall a. Maybe a
Nothing

projectName :: ProjectRoot -> ProjectName
projectName :: ProjectRoot -> ProjectName
projectName =
  Text -> ProjectName
ProjectName (Text -> ProjectName)
-> (ProjectRoot -> Text) -> ProjectRoot -> ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel Dir -> Text
forall b t. Path b t -> Text
dropSlash (Path Rel Dir -> Text)
-> (ProjectRoot -> Path Rel Dir) -> ProjectRoot -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname (Path Abs Dir -> Path Rel Dir)
-> (ProjectRoot -> Path Abs Dir) -> ProjectRoot -> Path Rel Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectRoot -> Path Abs Dir
unProjectRoot

firstJustMOr ::
  Monad m =>
  a ->
  [m (Maybe a)] ->
  m a
firstJustMOr :: forall (m :: * -> *) a. Monad m => a -> [m (Maybe a)] -> m a
firstJustMOr a
fallback =
  (Maybe a -> a) -> m (Maybe a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
fallback) (m (Maybe a) -> m a)
-> ([m (Maybe a)] -> m (Maybe a)) -> [m (Maybe a)] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m a -> m (Maybe a))
-> ([m (Maybe a)] -> MaybeT m a) -> [m (Maybe a)] -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum @[] ([MaybeT m a] -> MaybeT m a)
-> ([m (Maybe a)] -> [MaybeT m a]) -> [m (Maybe a)] -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (Maybe a) -> MaybeT m a) -> [m (Maybe a)] -> [MaybeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT

fromRoot ::
  Members [Stop ResolveError, Embed IO] r =>
  [ProjectSpec] ->
  ProjectConfig ->
  ProjectRoot ->
  Sem r Project
fromRoot :: forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[ProjectSpec] -> ProjectConfig -> ProjectRoot -> Sem r Project
fromRoot [ProjectSpec]
explicit config :: ProjectConfig
config@ProjectConfig {[Path Abs Dir]
Map ProjectLang [ProjectLang]
Map ProjectType [Text]
Map ProjectType [Path Abs Dir]
Map ProjectType [ProjectType]
Map ProjectType ProjectLang
$sel:langsMap:ProjectConfig :: ProjectConfig -> Map ProjectLang [ProjectLang]
$sel:langMap:ProjectConfig :: ProjectConfig -> Map ProjectType ProjectLang
$sel:typeMarkers:ProjectConfig :: ProjectConfig -> Map ProjectType [Text]
$sel:typeMap:ProjectConfig :: ProjectConfig -> Map ProjectType [ProjectType]
$sel:projectTypes:ProjectConfig :: ProjectConfig -> Map ProjectType [Path Abs Dir]
$sel:typeDirs:ProjectConfig :: ProjectConfig -> Map ProjectType [Path Abs Dir]
langsMap :: Map ProjectLang [ProjectLang]
langMap :: Map ProjectType ProjectLang
typeMarkers :: Map ProjectType [Text]
typeMap :: Map ProjectType [ProjectType]
projectTypes :: Map ProjectType [Path Abs Dir]
typeDirs :: Map ProjectType [Path Abs Dir]
baseDirs :: [Path Abs Dir]
$sel:baseDirs:ProjectConfig :: ProjectConfig -> [Path Abs Dir]
..} ProjectRoot
root = do
  let
    byRoot :: Maybe Project
byRoot =
      forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum @[] [
        [ProjectSpec] -> ProjectRoot -> Maybe Project
rootExplicit [ProjectSpec]
explicit ProjectRoot
root,
        Map ProjectType [Path Abs Dir]
-> ProjectName -> ProjectRoot -> Maybe Project
rootProjectTypes Map ProjectType [Path Abs Dir]
projectTypes ProjectName
name ProjectRoot
root,
        Map ProjectType [Path Abs Dir]
-> ProjectName -> ProjectRoot -> Maybe Project
rootTypeDirs Map ProjectType [Path Abs Dir]
typeDirs ProjectName
name ProjectRoot
root,
        [Path Abs Dir] -> ProjectName -> ProjectRoot -> Maybe Project
rootBaseDirs [Path Abs Dir]
baseDirs ProjectName
name ProjectRoot
root
        ]
  Project
project <- Project -> [Sem r (Maybe Project)] -> Sem r Project
forall (m :: * -> *) a. Monad m => a -> [m (Maybe a)] -> m a
firstJustMOr (ProjectName -> Project
virtualProject ProjectName
name) [
    Maybe Project -> Sem r (Maybe Project)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Project
byRoot,
    Map ProjectType [Text]
-> ProjectName -> ProjectRoot -> Sem r (Maybe Project)
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
Map ProjectType [Text]
-> ProjectName -> ProjectRoot -> Sem r (Maybe Project)
resolveFromDirContents Map ProjectType [Text]
typeMarkers ProjectName
name ProjectRoot
root
    ]
  pure (ProjectConfig -> Project -> Project
augmentFromConfig ProjectConfig
config Project
project)
  where
    name :: ProjectName
name =
      ProjectRoot -> ProjectName
projectName ProjectRoot
root

fromRootSettings ::
  Members [Settings, Stop ResolveError, Embed IO] r =>
  ProjectRoot ->
  Sem r Project
fromRootSettings :: forall (r :: EffectRow).
Members '[Settings, Stop ResolveError, Embed IO] r =>
ProjectRoot -> Sem r Project
fromRootSettings ProjectRoot
root = do
  [ProjectSpec]
explicit <- Setting [ProjectSpec] -> Sem r [ProjectSpec]
forall a (r :: EffectRow).
(MsgpackDecode a, Member Settings r) =>
Setting a -> Sem r a
Settings.get Setting [ProjectSpec]
Settings.projects
  ProjectConfig
config <- Sem r ProjectConfig
forall (r :: EffectRow). Member Settings r => Sem r ProjectConfig
projectConfig
  [ProjectSpec] -> ProjectConfig -> ProjectRoot -> Sem r Project
forall (r :: EffectRow).
Members '[Stop ResolveError, Embed IO] r =>
[ProjectSpec] -> ProjectConfig -> ProjectRoot -> Sem r Project
fromRoot [ProjectSpec]
explicit ProjectConfig
config ProjectRoot
root