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

module HWM.Core.Pkg
  ( Pkg (..),
    PkgName,
    makePkg,
    pkgFile,
    pkgYamlPath,
    pkgId,
    scanPkgs,
  )
where

import Control.Monad.Except
import Data.Aeson (FromJSON (..), ToJSONKey)
import Data.Aeson.Types (FromJSONKey)
import qualified Data.Map as Map
import Data.Text (intercalate)
import Data.Traversable (for)
import Data.Yaml.Aeson (ToJSON)
import HWM.Core.Common (Name)
import HWM.Core.Formatting
import HWM.Core.Parsing (Parse (..))
import HWM.Core.Result (Issue)
import HWM.Core.Version (Version)
import HWM.Runtime.Files (cleanRelativePath, readYaml)
import Relude hiding (Undefined, intercalate)
import System.FilePath (makeRelative, takeDirectory)
import System.FilePath.Glob (glob)
import System.FilePath.Posix (joinPath, normalise, takeFileName, (</>))

data PkgInfo = PkgInfo {PkgInfo -> PkgName
name :: PkgName, PkgInfo -> Version
version :: Version}
  deriving ((forall x. PkgInfo -> Rep PkgInfo x)
-> (forall x. Rep PkgInfo x -> PkgInfo) -> Generic PkgInfo
forall x. Rep PkgInfo x -> PkgInfo
forall x. PkgInfo -> Rep PkgInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PkgInfo -> Rep PkgInfo x
from :: forall x. PkgInfo -> Rep PkgInfo x
$cto :: forall x. Rep PkgInfo x -> PkgInfo
to :: forall x. Rep PkgInfo x -> PkgInfo
Generic, Maybe PkgInfo
Value -> Parser [PkgInfo]
Value -> Parser PkgInfo
(Value -> Parser PkgInfo)
-> (Value -> Parser [PkgInfo]) -> Maybe PkgInfo -> FromJSON PkgInfo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PkgInfo
parseJSON :: Value -> Parser PkgInfo
$cparseJSONList :: Value -> Parser [PkgInfo]
parseJSONList :: Value -> Parser [PkgInfo]
$comittedField :: Maybe PkgInfo
omittedField :: Maybe PkgInfo
FromJSON, Int -> PkgInfo -> ShowS
[PkgInfo] -> ShowS
PkgInfo -> FilePath
(Int -> PkgInfo -> ShowS)
-> (PkgInfo -> FilePath) -> ([PkgInfo] -> ShowS) -> Show PkgInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PkgInfo -> ShowS
showsPrec :: Int -> PkgInfo -> ShowS
$cshow :: PkgInfo -> FilePath
show :: PkgInfo -> FilePath
$cshowList :: [PkgInfo] -> ShowS
showList :: [PkgInfo] -> ShowS
Show)

data Pkg = Pkg
  { Pkg -> PkgName
pkgName :: PkgName,
    Pkg -> Version
pkgVersion :: Version,
    Pkg -> Text
pkgGroup :: Name,
    Pkg -> Text
pkgMemberId :: Name,
    Pkg -> FilePath
pkgDirPath :: FilePath
  }
  deriving (Int -> Pkg -> ShowS
[Pkg] -> ShowS
Pkg -> FilePath
(Int -> Pkg -> ShowS)
-> (Pkg -> FilePath) -> ([Pkg] -> ShowS) -> Show Pkg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pkg -> ShowS
showsPrec :: Int -> Pkg -> ShowS
$cshow :: Pkg -> FilePath
show :: Pkg -> FilePath
$cshowList :: [Pkg] -> ShowS
showList :: [Pkg] -> ShowS
Show, Eq Pkg
Eq Pkg =>
(Pkg -> Pkg -> Ordering)
-> (Pkg -> Pkg -> Bool)
-> (Pkg -> Pkg -> Bool)
-> (Pkg -> Pkg -> Bool)
-> (Pkg -> Pkg -> Bool)
-> (Pkg -> Pkg -> Pkg)
-> (Pkg -> Pkg -> Pkg)
-> Ord Pkg
Pkg -> Pkg -> Bool
Pkg -> Pkg -> Ordering
Pkg -> Pkg -> Pkg
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pkg -> Pkg -> Ordering
compare :: Pkg -> Pkg -> Ordering
$c< :: Pkg -> Pkg -> Bool
< :: Pkg -> Pkg -> Bool
$c<= :: Pkg -> Pkg -> Bool
<= :: Pkg -> Pkg -> Bool
$c> :: Pkg -> Pkg -> Bool
> :: Pkg -> Pkg -> Bool
$c>= :: Pkg -> Pkg -> Bool
>= :: Pkg -> Pkg -> Bool
$cmax :: Pkg -> Pkg -> Pkg
max :: Pkg -> Pkg -> Pkg
$cmin :: Pkg -> Pkg -> Pkg
min :: Pkg -> Pkg -> Pkg
Ord, Pkg -> Pkg -> Bool
(Pkg -> Pkg -> Bool) -> (Pkg -> Pkg -> Bool) -> Eq Pkg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pkg -> Pkg -> Bool
== :: Pkg -> Pkg -> Bool
$c/= :: Pkg -> Pkg -> Bool
/= :: Pkg -> Pkg -> Bool
Eq)

packageYamlFileName :: String
packageYamlFileName :: FilePath
packageYamlFileName = FilePath
"package.yaml"

-- Helper to ensure "package.yaml" is only appended if not already present
ensurePackageYaml :: FilePath -> FilePath
ensurePackageYaml :: ShowS
ensurePackageYaml FilePath
path
  | ShowS
takeFileName FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
packageYamlFileName = FilePath
path
  | Bool
otherwise = ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> ShowS
</> FilePath
packageYamlFileName

pkgYamlPath :: Pkg -> FilePath
pkgYamlPath :: Pkg -> FilePath
pkgYamlPath Pkg
pkg = Pkg -> ShowS
pkgFile Pkg
pkg FilePath
packageYamlFileName

getPkgInfo :: (MonadError Issue m, MonadIO m) => FilePath -> m PkgInfo
getPkgInfo :: forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
FilePath -> m PkgInfo
getPkgInfo = FilePath -> m PkgInfo
forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
FilePath -> m a
readYaml (FilePath -> m PkgInfo) -> ShowS -> FilePath -> m PkgInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
ensurePackageYaml

pkgFile :: Pkg -> FilePath -> FilePath
pkgFile :: Pkg -> ShowS
pkgFile Pkg {FilePath
Text
Version
PkgName
pkgName :: Pkg -> PkgName
pkgVersion :: Pkg -> Version
pkgGroup :: Pkg -> Text
pkgMemberId :: Pkg -> Text
pkgDirPath :: Pkg -> FilePath
pkgName :: PkgName
pkgVersion :: Version
pkgGroup :: Text
pkgMemberId :: Text
pkgDirPath :: FilePath
..} FilePath
file = ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
joinPath [FilePath
pkgDirPath, FilePath
file]

pkgId :: Pkg -> Text
pkgId :: Pkg -> Text
pkgId Pkg {Text
pkgGroup :: Pkg -> Text
pkgGroup :: Text
pkgGroup, Text
pkgMemberId :: Pkg -> Text
pkgMemberId :: Text
pkgMemberId} = Text
pkgGroup Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkgMemberId

toPkg :: PkgInfo -> Name -> Name -> FilePath -> Pkg
toPkg :: PkgInfo -> Text -> Text -> FilePath -> Pkg
toPkg PkgInfo {PkgName
name :: PkgInfo -> PkgName
name :: PkgName
name, Version
version :: PkgInfo -> Version
version :: Version
version} Text
groupName Text
memberName FilePath
dir =
  Pkg
    { pkgName :: PkgName
pkgName = PkgName
name,
      pkgVersion :: Version
pkgVersion = Version
version,
      pkgGroup :: Text
pkgGroup = Text
groupName,
      pkgMemberId :: Text
pkgMemberId = if Text
memberName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"." then Text
"(root)" else Text
memberName,
      pkgDirPath :: FilePath
pkgDirPath = FilePath
dir
    }

makePkg :: (MonadIO m, MonadError Issue m) => Text -> Maybe FilePath -> Maybe Name -> Name -> m Pkg
makePkg :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Text -> Maybe FilePath -> Maybe Text -> Text -> m Pkg
makePkg Text
groupName Maybe FilePath
root Maybe Text
prefix Text
memberName = do
  let pkgDirPath :: FilePath
pkgDirPath = Maybe FilePath -> Text -> FilePath
forall a. ToString a => Maybe FilePath -> a -> FilePath
resolvePath Maybe FilePath
root (Maybe Text -> Text -> Text
resolvePrefix Maybe Text
prefix Text
memberName)
  PkgInfo
json <- FilePath -> m PkgInfo
forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
FilePath -> m PkgInfo
getPkgInfo FilePath
pkgDirPath
  Pkg -> m Pkg
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pkg -> m Pkg) -> Pkg -> m Pkg
forall a b. (a -> b) -> a -> b
$ PkgInfo -> Text -> Text -> FilePath -> Pkg
toPkg PkgInfo
json Text
groupName Text
memberName FilePath
pkgDirPath

resolvePrefix :: Maybe Text -> Text -> Text
resolvePrefix :: Maybe Text -> Text -> Text
resolvePrefix Maybe Text
prefix Text
name = Text -> [Text] -> Text
intercalate Text
"-" (Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList Maybe Text
prefix [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
name | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"."])

resolvePath :: (ToString a) => Maybe String -> a -> FilePath
resolvePath :: forall a. ToString a => Maybe FilePath -> a -> FilePath
resolvePath Maybe FilePath
root a
path = ShowS
normalise ([FilePath] -> FilePath
joinPath (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (Maybe FilePath -> Maybe FilePath
cleanRelativePath Maybe FilePath
root) [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [a -> FilePath
forall a. ToString a => a -> FilePath
toString a
path]))

scanPkgInfos :: (MonadIO m, MonadError Issue m) => FilePath -> m (Map FilePath PkgInfo)
scanPkgInfos :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
FilePath -> m (Map FilePath PkgInfo)
scanPkgInfos FilePath
root = do
  [FilePath]
paths <- ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ShowS
makeRelative FilePath
root) ([FilePath] -> [FilePath]) -> m [FilePath] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
glob (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ ShowS
normalise FilePath
"./**/**/package.yaml")
  [PkgInfo]
pkgInfos <- (FilePath -> m PkgInfo) -> [FilePath] -> m [PkgInfo]
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 FilePath -> m PkgInfo
forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
FilePath -> m PkgInfo
getPkgInfo [FilePath]
paths
  Map FilePath PkgInfo -> m (Map FilePath PkgInfo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath PkgInfo -> m (Map FilePath PkgInfo))
-> Map FilePath PkgInfo -> m (Map FilePath PkgInfo)
forall a b. (a -> b) -> a -> b
$ [(FilePath, PkgInfo)] -> Map FilePath PkgInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([FilePath] -> [PkgInfo] -> [(FilePath, PkgInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
paths [PkgInfo]
pkgInfos)

scanPkgs :: (MonadIO m, MonadError Issue m) => FilePath -> m [Pkg]
scanPkgs :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
FilePath -> m [Pkg]
scanPkgs FilePath
root = do
  Map FilePath PkgInfo
infos <- FilePath -> m (Map FilePath PkgInfo)
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
FilePath -> m (Map FilePath PkgInfo)
scanPkgInfos FilePath
root
  [(FilePath, PkgInfo)] -> ((FilePath, PkgInfo) -> m Pkg) -> m [Pkg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map FilePath PkgInfo -> [(FilePath, PkgInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath PkgInfo
infos) (((FilePath, PkgInfo) -> m Pkg) -> m [Pkg])
-> ((FilePath, PkgInfo) -> m Pkg) -> m [Pkg]
forall a b. (a -> b) -> a -> b
$ \(FilePath
path, PkgInfo
info) -> do
    let pkgDir :: FilePath
pkgDir = ShowS
takeDirectory FilePath
path
    let memberName :: Text
memberName = FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName FilePath
pkgDir
    let groupName :: Text
groupName = Text -> (FilePath -> Text) -> Maybe FilePath -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" FilePath -> Text
forall a. ToText a => a -> Text
toText (Maybe FilePath -> Text) -> Maybe FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Maybe FilePath
cleanRelativePath (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
takeDirectory FilePath
pkgDir))
    Pkg -> m Pkg
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pkg -> m Pkg) -> Pkg -> m Pkg
forall a b. (a -> b) -> a -> b
$ PkgInfo -> Text -> Text -> FilePath -> Pkg
toPkg PkgInfo
info Text
groupName Text
memberName FilePath
pkgDir

newtype PkgName = PkgName Text
  deriving newtype
    ( Maybe PkgName
Value -> Parser [PkgName]
Value -> Parser PkgName
(Value -> Parser PkgName)
-> (Value -> Parser [PkgName]) -> Maybe PkgName -> FromJSON PkgName
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PkgName
parseJSON :: Value -> Parser PkgName
$cparseJSONList :: Value -> Parser [PkgName]
parseJSONList :: Value -> Parser [PkgName]
$comittedField :: Maybe PkgName
omittedField :: Maybe PkgName
FromJSON,
      [PkgName] -> Value
[PkgName] -> Encoding
PkgName -> Bool
PkgName -> Value
PkgName -> Encoding
(PkgName -> Value)
-> (PkgName -> Encoding)
-> ([PkgName] -> Value)
-> ([PkgName] -> Encoding)
-> (PkgName -> Bool)
-> ToJSON PkgName
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PkgName -> Value
toJSON :: PkgName -> Value
$ctoEncoding :: PkgName -> Encoding
toEncoding :: PkgName -> Encoding
$ctoJSONList :: [PkgName] -> Value
toJSONList :: [PkgName] -> Value
$ctoEncodingList :: [PkgName] -> Encoding
toEncodingList :: [PkgName] -> Encoding
$comitField :: PkgName -> Bool
omitField :: PkgName -> Bool
ToJSON,
      Int -> PkgName -> ShowS
[PkgName] -> ShowS
PkgName -> FilePath
(Int -> PkgName -> ShowS)
-> (PkgName -> FilePath) -> ([PkgName] -> ShowS) -> Show PkgName
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PkgName -> ShowS
showsPrec :: Int -> PkgName -> ShowS
$cshow :: PkgName -> FilePath
show :: PkgName -> FilePath
$cshowList :: [PkgName] -> ShowS
showList :: [PkgName] -> ShowS
Show,
      Eq PkgName
Eq PkgName =>
(PkgName -> PkgName -> Ordering)
-> (PkgName -> PkgName -> Bool)
-> (PkgName -> PkgName -> Bool)
-> (PkgName -> PkgName -> Bool)
-> (PkgName -> PkgName -> Bool)
-> (PkgName -> PkgName -> PkgName)
-> (PkgName -> PkgName -> PkgName)
-> Ord PkgName
PkgName -> PkgName -> Bool
PkgName -> PkgName -> Ordering
PkgName -> PkgName -> PkgName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PkgName -> PkgName -> Ordering
compare :: PkgName -> PkgName -> Ordering
$c< :: PkgName -> PkgName -> Bool
< :: PkgName -> PkgName -> Bool
$c<= :: PkgName -> PkgName -> Bool
<= :: PkgName -> PkgName -> Bool
$c> :: PkgName -> PkgName -> Bool
> :: PkgName -> PkgName -> Bool
$c>= :: PkgName -> PkgName -> Bool
>= :: PkgName -> PkgName -> Bool
$cmax :: PkgName -> PkgName -> PkgName
max :: PkgName -> PkgName -> PkgName
$cmin :: PkgName -> PkgName -> PkgName
min :: PkgName -> PkgName -> PkgName
Ord,
      PkgName -> PkgName -> Bool
(PkgName -> PkgName -> Bool)
-> (PkgName -> PkgName -> Bool) -> Eq PkgName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PkgName -> PkgName -> Bool
== :: PkgName -> PkgName -> Bool
$c/= :: PkgName -> PkgName -> Bool
/= :: PkgName -> PkgName -> Bool
Eq,
      FromJSONKeyFunction [PkgName]
FromJSONKeyFunction PkgName
FromJSONKeyFunction PkgName
-> FromJSONKeyFunction [PkgName] -> FromJSONKey PkgName
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction PkgName
fromJSONKey :: FromJSONKeyFunction PkgName
$cfromJSONKeyList :: FromJSONKeyFunction [PkgName]
fromJSONKeyList :: FromJSONKeyFunction [PkgName]
FromJSONKey,
      ToJSONKeyFunction [PkgName]
ToJSONKeyFunction PkgName
ToJSONKeyFunction PkgName
-> ToJSONKeyFunction [PkgName] -> ToJSONKey PkgName
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction PkgName
toJSONKey :: ToJSONKeyFunction PkgName
$ctoJSONKeyList :: ToJSONKeyFunction [PkgName]
toJSONKeyList :: ToJSONKeyFunction [PkgName]
ToJSONKey,
      PkgName -> FilePath
(PkgName -> FilePath) -> ToString PkgName
forall a. (a -> FilePath) -> ToString a
$ctoString :: PkgName -> FilePath
toString :: PkgName -> FilePath
ToString
    )

instance Format PkgName where
  format :: PkgName -> Text
format (PkgName Text
x) = Text
x

instance Parse PkgName where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m PkgName
parse = PkgName -> m PkgName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PkgName -> m PkgName) -> (Text -> PkgName) -> Text -> m PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PkgName
PkgName