{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Domain.Workspace
  ( WorkspaceGroup (..),
    pkgGroupName,
    pkgRegistry,
    PkgRegistry,
    memberPkgs,
    resolveTargets,
    selectGroup,
    canPublish,
    buildWorkspaceGroups,
  )
where

import Control.Monad.Error.Class
import Data.Aeson
  ( FromJSON (..),
    Options (..),
    ToJSON (toJSON),
    genericToJSON,
  )
import Data.Aeson.Types
  ( defaultOptions,
  )
import Data.List (groupBy)
import qualified Data.Map as Map
import qualified Data.Text as T
import HWM.Core.Common (Name)
import HWM.Core.Formatting (availableOptions, commonPrefix, slugify)
import HWM.Core.Pkg (Pkg (..), PkgName, makePkg)
import HWM.Core.Result
import HWM.Domain.Dependencies (DependencyGraph, sortByDependencyHierarchy)
import HWM.Runtime.Files (cleanRelativePath)
import Relude

data WorkspaceGroup = WorkspaceGroup
  { WorkspaceGroup -> Text
name :: Name,
    WorkspaceGroup -> Maybe FilePath
dir :: Maybe FilePath,
    WorkspaceGroup -> [Text]
members :: [Name],
    WorkspaceGroup -> Maybe Text
prefix :: Maybe Text,
    WorkspaceGroup -> Maybe Bool
publish :: Maybe Bool
  }
  deriving
    ( (forall x. WorkspaceGroup -> Rep WorkspaceGroup x)
-> (forall x. Rep WorkspaceGroup x -> WorkspaceGroup)
-> Generic WorkspaceGroup
forall x. Rep WorkspaceGroup x -> WorkspaceGroup
forall x. WorkspaceGroup -> Rep WorkspaceGroup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WorkspaceGroup -> Rep WorkspaceGroup x
from :: forall x. WorkspaceGroup -> Rep WorkspaceGroup x
$cto :: forall x. Rep WorkspaceGroup x -> WorkspaceGroup
to :: forall x. Rep WorkspaceGroup x -> WorkspaceGroup
Generic,
      Maybe WorkspaceGroup
Value -> Parser [WorkspaceGroup]
Value -> Parser WorkspaceGroup
(Value -> Parser WorkspaceGroup)
-> (Value -> Parser [WorkspaceGroup])
-> Maybe WorkspaceGroup
-> FromJSON WorkspaceGroup
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser WorkspaceGroup
parseJSON :: Value -> Parser WorkspaceGroup
$cparseJSONList :: Value -> Parser [WorkspaceGroup]
parseJSONList :: Value -> Parser [WorkspaceGroup]
$comittedField :: Maybe WorkspaceGroup
omittedField :: Maybe WorkspaceGroup
FromJSON,
      Int -> WorkspaceGroup -> ShowS
[WorkspaceGroup] -> ShowS
WorkspaceGroup -> FilePath
(Int -> WorkspaceGroup -> ShowS)
-> (WorkspaceGroup -> FilePath)
-> ([WorkspaceGroup] -> ShowS)
-> Show WorkspaceGroup
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorkspaceGroup -> ShowS
showsPrec :: Int -> WorkspaceGroup -> ShowS
$cshow :: WorkspaceGroup -> FilePath
show :: WorkspaceGroup -> FilePath
$cshowList :: [WorkspaceGroup] -> ShowS
showList :: [WorkspaceGroup] -> ShowS
Show
    )

instance ToJSON WorkspaceGroup where
  toJSON :: WorkspaceGroup -> Value
toJSON = Options -> WorkspaceGroup -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {omitNothingFields = True}

memberPkgs :: (MonadIO m, MonadError Issue m) => WorkspaceGroup -> m [Pkg]
memberPkgs :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs WorkspaceGroup {[Text]
Maybe Bool
Maybe FilePath
Maybe Text
Text
name :: WorkspaceGroup -> Text
dir :: WorkspaceGroup -> Maybe FilePath
members :: WorkspaceGroup -> [Text]
prefix :: WorkspaceGroup -> Maybe Text
publish :: WorkspaceGroup -> Maybe Bool
name :: Text
dir :: Maybe FilePath
members :: [Text]
prefix :: Maybe Text
publish :: Maybe Bool
..} = (Text -> m Pkg) -> [Text] -> m [Pkg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text -> Maybe FilePath -> Maybe Text -> Text -> m Pkg
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Text -> Maybe FilePath -> Maybe Text -> Text -> m Pkg
makePkg Text
name Maybe FilePath
dir Maybe Text
prefix) [Text]
members

pkgGroupName :: WorkspaceGroup -> Name
pkgGroupName :: WorkspaceGroup -> Text
pkgGroupName WorkspaceGroup {[Text]
Maybe Bool
Maybe FilePath
Maybe Text
Text
name :: WorkspaceGroup -> Text
dir :: WorkspaceGroup -> Maybe FilePath
members :: WorkspaceGroup -> [Text]
prefix :: WorkspaceGroup -> Maybe Text
publish :: WorkspaceGroup -> Maybe Bool
name :: Text
dir :: Maybe FilePath
members :: [Text]
prefix :: Maybe Text
publish :: Maybe Bool
..} = Text
name

type PkgRegistry = Map PkgName WorkspaceGroup

resolveGroup :: (MonadIO m, MonadError Issue m) => WorkspaceGroup -> m PkgRegistry
resolveGroup :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m PkgRegistry
resolveGroup WorkspaceGroup
g = [(PkgName, WorkspaceGroup)] -> PkgRegistry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PkgName, WorkspaceGroup)] -> PkgRegistry)
-> ([Pkg] -> [(PkgName, WorkspaceGroup)]) -> [Pkg] -> PkgRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pkg -> (PkgName, WorkspaceGroup))
-> [Pkg] -> [(PkgName, WorkspaceGroup)]
forall a b. (a -> b) -> [a] -> [b]
map ((,WorkspaceGroup
g) (PkgName -> (PkgName, WorkspaceGroup))
-> (Pkg -> PkgName) -> Pkg -> (PkgName, WorkspaceGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> PkgName
pkgName) ([Pkg] -> PkgRegistry) -> m [Pkg] -> m PkgRegistry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceGroup -> m [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs WorkspaceGroup
g

pkgRegistry :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> m PkgRegistry
pkgRegistry :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[WorkspaceGroup] -> m PkgRegistry
pkgRegistry = ([PkgRegistry] -> PkgRegistry) -> m [PkgRegistry] -> m PkgRegistry
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PkgRegistry] -> PkgRegistry
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (m [PkgRegistry] -> m PkgRegistry)
-> ([WorkspaceGroup] -> m [PkgRegistry])
-> [WorkspaceGroup]
-> m PkgRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceGroup -> m PkgRegistry)
-> [WorkspaceGroup] -> m [PkgRegistry]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse WorkspaceGroup -> m PkgRegistry
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m PkgRegistry
resolveGroup

parseTarget :: Text -> (Text, Maybe Text)
parseTarget :: Text -> (Text, Maybe Text)
parseTarget Text
input = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"/" Text
input of
  (Text
pkg, Text
"") -> (Text
pkg, Maybe Text
forall a. Maybe a
Nothing) -- No slash found
  (Text
grp, Text
rest) -> (Text
grp, Text -> Maybe Text
forall a. a -> Maybe a
Just (Int -> Text -> Text
T.drop Int
1 Text
rest)) -- Drop the "/"

resolveTargets :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> [Name] -> m [Pkg]
resolveTargets :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[WorkspaceGroup] -> [Text] -> m [Pkg]
resolveTargets [WorkspaceGroup]
ws [Text]
names = [[Pkg]] -> [Pkg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Pkg]] -> [Pkg]) -> m [[Pkg]] -> m [Pkg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m [Pkg]) -> [Text] -> m [[Pkg]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([WorkspaceGroup] -> Text -> m [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[WorkspaceGroup] -> Text -> m [Pkg]
resolveTarget [WorkspaceGroup]
ws) [Text]
names

resolveTarget :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> Text -> m [Pkg]
resolveTarget :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[WorkspaceGroup] -> Text -> m [Pkg]
resolveTarget [WorkspaceGroup]
ws Text
target = do
  let (Text
g, Maybe Text
n) = Text -> (Text, Maybe Text)
parseTarget Text
target
  [Pkg]
members <- Text -> [WorkspaceGroup] -> m WorkspaceGroup
forall (m :: * -> *).
MonadError Issue m =>
Text -> [WorkspaceGroup] -> m WorkspaceGroup
selectGroup Text
g [WorkspaceGroup]
ws m WorkspaceGroup -> (WorkspaceGroup -> m [Pkg]) -> m [Pkg]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WorkspaceGroup -> m [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs
  [Pkg] -> Maybe Text -> m [Pkg]
forall (m :: * -> *).
MonadError Issue m =>
[Pkg] -> Maybe Text -> m [Pkg]
resolveT [Pkg]
members Maybe Text
n

selectGroup :: (MonadError Issue m) => Name -> [WorkspaceGroup] -> m WorkspaceGroup
selectGroup :: forall (m :: * -> *).
MonadError Issue m =>
Text -> [WorkspaceGroup] -> m WorkspaceGroup
selectGroup Text
name [WorkspaceGroup]
groups =
  m WorkspaceGroup
-> (WorkspaceGroup -> m WorkspaceGroup)
-> Maybe WorkspaceGroup
-> m WorkspaceGroup
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Issue -> m WorkspaceGroup
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m WorkspaceGroup) -> Issue -> m WorkspaceGroup
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text
"Workspace group \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" not found! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Format a => [a] -> Text
availableOptions ((WorkspaceGroup -> Text) -> [WorkspaceGroup] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceGroup -> Text
pkgGroupName [WorkspaceGroup]
groups))) WorkspaceGroup -> m WorkspaceGroup
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((WorkspaceGroup -> Bool)
-> [WorkspaceGroup] -> Maybe WorkspaceGroup
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool)
-> (WorkspaceGroup -> Text) -> WorkspaceGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceGroup -> Text
pkgGroupName) [WorkspaceGroup]
groups)

resolveT :: (MonadError Issue m) => [Pkg] -> Maybe Name -> m [Pkg]
resolveT :: forall (m :: * -> *).
MonadError Issue m =>
[Pkg] -> Maybe Text -> m [Pkg]
resolveT [Pkg]
pkgs Maybe Text
Nothing = [Pkg] -> m [Pkg]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Pkg]
pkgs
resolveT [Pkg]
pkgs (Just Text
target) =
  case (Pkg -> Bool) -> [Pkg] -> Maybe Pkg
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Pkg
p -> Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Pkg -> Text
pkgMemberId Pkg
p) [Pkg]
pkgs of
    Just Pkg
p -> [Pkg] -> m [Pkg]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Pkg
p]
    Maybe Pkg
Nothing -> Issue -> m [Pkg]
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m [Pkg]) -> Issue -> m [Pkg]
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Target not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
target

canPublish :: WorkspaceGroup -> Bool
canPublish :: WorkspaceGroup -> Bool
canPublish WorkspaceGroup {Maybe Bool
publish :: WorkspaceGroup -> Maybe Bool
publish :: Maybe Bool
publish} = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
publish

buildWorkspaceGroups :: (Monad m, MonadError Issue m) => DependencyGraph -> [Pkg] -> m [WorkspaceGroup]
buildWorkspaceGroups :: forall (m :: * -> *).
(Monad m, MonadError Issue m) =>
DependencyGraph -> [Pkg] -> m [WorkspaceGroup]
buildWorkspaceGroups DependencyGraph
graph = ([[WorkspaceGroup]] -> [WorkspaceGroup])
-> m [[WorkspaceGroup]] -> m [WorkspaceGroup]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[WorkspaceGroup]] -> [WorkspaceGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[WorkspaceGroup]] -> m [WorkspaceGroup])
-> ([Pkg] -> m [[WorkspaceGroup]]) -> [Pkg] -> m [WorkspaceGroup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Pkg] -> m [WorkspaceGroup]) -> [[Pkg]] -> m [[WorkspaceGroup]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Pkg] -> m [WorkspaceGroup]
forall {f :: * -> *}.
MonadError Issue f =>
[Pkg] -> f [WorkspaceGroup]
groupToWorkspace ([[Pkg]] -> m [[WorkspaceGroup]])
-> ([Pkg] -> [[Pkg]]) -> [Pkg] -> m [[WorkspaceGroup]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pkg -> Pkg -> Bool) -> [Pkg] -> [[Pkg]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Pkg -> Pkg -> Bool
sameGroup ([Pkg] -> [[Pkg]]) -> ([Pkg] -> [Pkg]) -> [Pkg] -> [[Pkg]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pkg -> Text) -> [Pkg] -> [Pkg]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Pkg -> Text
pkgGroup
  where
    sameGroup :: Pkg -> Pkg -> Bool
sameGroup Pkg
left Pkg
right = Pkg -> Text
pkgGroup Pkg
left Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Pkg -> Text
pkgGroup Pkg
right
    groupToWorkspace :: [Pkg] -> f [WorkspaceGroup]
groupToWorkspace [] = [WorkspaceGroup] -> f [WorkspaceGroup]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    groupToWorkspace (Pkg
pkg : [Pkg]
pkgs) = do
      [Pkg]
sortPkgs <- DependencyGraph -> [Pkg] -> f [Pkg]
forall (m :: * -> *).
MonadError Issue m =>
DependencyGraph -> [Pkg] -> m [Pkg]
sortByDependencyHierarchy DependencyGraph
graph (Pkg
pkg Pkg -> [Pkg] -> [Pkg]
forall a. a -> [a] -> [a]
: [Pkg]
pkgs)
      let (Maybe Text
prefix, [Text]
members) = [Text] -> (Maybe Text, [Text])
commonPrefix ((Pkg -> Text) -> [Pkg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> Text
pkgMemberId [Pkg]
sortPkgs)
      [WorkspaceGroup] -> f [WorkspaceGroup]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ WorkspaceGroup
            { name :: Text
name = if Text -> Bool
T.null (Pkg -> Text
pkgGroup Pkg
pkg) then Text
"libs" else Text -> Text
slugify (Pkg -> Text
pkgGroup Pkg
pkg),
              dir :: Maybe FilePath
dir = Maybe FilePath -> Maybe FilePath
cleanRelativePath (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Pkg -> Text
pkgGroup Pkg
pkg)),
              [Text]
members :: [Text]
members :: [Text]
members,
              prefix :: Maybe Text
prefix = Maybe Text
prefix,
              publish :: Maybe Bool
publish = [Text] -> Maybe Bool
derivePublish (Pkg -> Text
pkgGroup Pkg
pkg Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
members)
            }
        ]

derivePublish :: [Name] -> Maybe Bool
derivePublish :: [Text] -> Maybe Bool
derivePublish [Text]
names
  | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
nonPublish) [Text]
loweredNames = Maybe Bool
forall a. Maybe a
Nothing
  | Bool
otherwise = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  where
    loweredNames :: [Text]
loweredNames = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toLower [Text]
names
    nonPublish :: [Text]
nonPublish = [Text
"examples", Text
"example", Text
"bench", Text
"benchmarks"]