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

module HWM.Integrations.Toolchain.Hie
  ( syncHie,
  )
where

import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object)
import qualified Data.Map as M
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Format (..))
import HWM.Core.Options (Options (..), askOptions)
import HWM.Core.Pkg (Pkg (..), PkgName, pkgFile, pkgYamlPath)
import HWM.Domain.ConfigT (ConfigT, askPackages)
import HWM.Integrations.Toolchain.Lib (Libraries, Library (..))
import HWM.Integrations.Toolchain.Package (Package (..))
import HWM.Runtime.Files (readYaml, rewrite_)
import Relude

data Component = Component
  { Component -> FilePath
path :: FilePath,
    Component -> Name
component :: Name
  }
  deriving
    ( [Component] -> Value
[Component] -> Encoding
Component -> Bool
Component -> Value
Component -> Encoding
(Component -> Value)
-> (Component -> Encoding)
-> ([Component] -> Value)
-> ([Component] -> Encoding)
-> (Component -> Bool)
-> ToJSON Component
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Component -> Value
toJSON :: Component -> Value
$ctoEncoding :: Component -> Encoding
toEncoding :: Component -> Encoding
$ctoJSONList :: [Component] -> Value
toJSONList :: [Component] -> Value
$ctoEncodingList :: [Component] -> Encoding
toEncodingList :: [Component] -> Encoding
$comitField :: Component -> Bool
omitField :: Component -> Bool
ToJSON,
      Maybe Component
Value -> Parser [Component]
Value -> Parser Component
(Value -> Parser Component)
-> (Value -> Parser [Component])
-> Maybe Component
-> FromJSON Component
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Component
parseJSON :: Value -> Parser Component
$cparseJSONList :: Value -> Parser [Component]
parseJSONList :: Value -> Parser [Component]
$comittedField :: Maybe Component
omittedField :: Maybe Component
FromJSON,
      (forall x. Component -> Rep Component x)
-> (forall x. Rep Component x -> Component) -> Generic Component
forall x. Rep Component x -> Component
forall x. Component -> Rep Component x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Component -> Rep Component x
from :: forall x. Component -> Rep Component x
$cto :: forall x. Rep Component x -> Component
to :: forall x. Rep Component x -> Component
Generic,
      Int -> Component -> ShowS
[Component] -> ShowS
Component -> FilePath
(Int -> Component -> ShowS)
-> (Component -> FilePath)
-> ([Component] -> ShowS)
-> Show Component
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Component -> ShowS
showsPrec :: Int -> Component -> ShowS
$cshow :: Component -> FilePath
show :: Component -> FilePath
$cshowList :: [Component] -> ShowS
showList :: [Component] -> ShowS
Show
    )

data Components = Components
  { Components -> FilePath
stackYaml :: FilePath,
    Components -> [Component]
components :: [Component]
  }
  deriving
    ( [Components] -> Value
[Components] -> Encoding
Components -> Bool
Components -> Value
Components -> Encoding
(Components -> Value)
-> (Components -> Encoding)
-> ([Components] -> Value)
-> ([Components] -> Encoding)
-> (Components -> Bool)
-> ToJSON Components
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Components -> Value
toJSON :: Components -> Value
$ctoEncoding :: Components -> Encoding
toEncoding :: Components -> Encoding
$ctoJSONList :: [Components] -> Value
toJSONList :: [Components] -> Value
$ctoEncodingList :: [Components] -> Encoding
toEncodingList :: [Components] -> Encoding
$comitField :: Components -> Bool
omitField :: Components -> Bool
ToJSON,
      Maybe Components
Value -> Parser [Components]
Value -> Parser Components
(Value -> Parser Components)
-> (Value -> Parser [Components])
-> Maybe Components
-> FromJSON Components
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Components
parseJSON :: Value -> Parser Components
$cparseJSONList :: Value -> Parser [Components]
parseJSONList :: Value -> Parser [Components]
$comittedField :: Maybe Components
omittedField :: Maybe Components
FromJSON,
      (forall x. Components -> Rep Components x)
-> (forall x. Rep Components x -> Components) -> Generic Components
forall x. Rep Components x -> Components
forall x. Components -> Rep Components x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Components -> Rep Components x
from :: forall x. Components -> Rep Components x
$cto :: forall x. Rep Components x -> Components
to :: forall x. Rep Components x -> Components
Generic,
      Int -> Components -> ShowS
[Components] -> ShowS
Components -> FilePath
(Int -> Components -> ShowS)
-> (Components -> FilePath)
-> ([Components] -> ShowS)
-> Show Components
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Components -> ShowS
showsPrec :: Int -> Components -> ShowS
$cshow :: Components -> FilePath
show :: Components -> FilePath
$cshowList :: [Components] -> ShowS
showList :: [Components] -> ShowS
Show
    )

packHie :: Components -> Value
packHie :: Components -> Value
packHie Components
value = [Pair] -> Value
object [(Key
"cradle", [Pair] -> Value
object [(Key
"stack", Components -> Value
forall a. ToJSON a => a -> Value
toJSON Components
value)])]

(<:>) :: (Semigroup a, IsString a) => a -> a -> a
<:> :: forall a. (Semigroup a, IsString a) => a -> a -> a
(<:>) a
name a
tag = a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
":" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
tag

genComponents :: Pkg -> ConfigT [Component]
genComponents :: Pkg -> ConfigT [Component]
genComponents Pkg
path = do
  Package {Maybe Libraries
Maybe Library
Version
PkgName
Dependencies
name :: PkgName
version :: Version
library :: Maybe Library
dependencies :: Dependencies
tests :: Maybe Libraries
executables :: Maybe Libraries
benchmarks :: Maybe Libraries
internalLibraries :: Maybe Libraries
foreignLibraries :: Maybe Libraries
foreignLibraries :: Package -> Maybe Libraries
internalLibraries :: Package -> Maybe Libraries
benchmarks :: Package -> Maybe Libraries
executables :: Package -> Maybe Libraries
tests :: Package -> Maybe Libraries
dependencies :: Package -> Dependencies
library :: Package -> Maybe Library
version :: Package -> Version
name :: Package -> PkgName
..} <- FilePath -> ConfigT Package
forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
FilePath -> m a
readYaml (Pkg -> FilePath
pkgYamlPath Pkg
path)
  [Component] -> ConfigT [Component]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ([Component] -> ConfigT [Component])
-> [Component] -> ConfigT [Component]
forall a b. (a -> b) -> a -> b
$ PkgName -> Name -> Maybe Library -> [Component]
comp PkgName
name Name
"lib" Maybe Library
library
    [Component] -> [Component] -> [Component]
forall a. Semigroup a => a -> a -> a
<> PkgName -> Name -> Maybe Libraries -> [Component]
compGroup PkgName
name Name
"test" Maybe Libraries
tests
    [Component] -> [Component] -> [Component]
forall a. Semigroup a => a -> a -> a
<> PkgName -> Name -> Maybe Libraries -> [Component]
compGroup PkgName
name Name
"exe" Maybe Libraries
executables
    [Component] -> [Component] -> [Component]
forall a. Semigroup a => a -> a -> a
<> PkgName -> Name -> Maybe Libraries -> [Component]
compGroup PkgName
name Name
"bench" Maybe Libraries
benchmarks
  where
    compGroup :: PkgName -> Text -> Maybe Libraries -> [Component]
    compGroup :: PkgName -> Name -> Maybe Libraries -> [Component]
compGroup PkgName
name Name
tag = ((Name, Library) -> [Component])
-> [(Name, Library)] -> [Component]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, Library) -> [Component]
mkComp ([(Name, Library)] -> [Component])
-> (Maybe Libraries -> [(Name, Library)])
-> Maybe Libraries
-> [Component]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Libraries -> [(Name, Library)])
-> [Libraries] -> [(Name, Library)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Libraries -> [(Name, Library)]
forall k a. Map k a -> [(k, a)]
M.toList ([Libraries] -> [(Name, Library)])
-> (Maybe Libraries -> [Libraries])
-> Maybe Libraries
-> [(Name, Library)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Libraries -> [Libraries]
forall a. Maybe a -> [a]
maybeToList
      where
        mkComp :: (Name, Library) -> [Component]
mkComp (Name
k, Library
lib) = PkgName -> Name -> Maybe Library -> [Component]
comp PkgName
name (Name
tag Name -> Name -> Name
forall a. (Semigroup a, IsString a) => a -> a -> a
<:> Name
k) (Library -> Maybe Library
forall a. a -> Maybe a
Just Library
lib)
    comp :: PkgName -> Text -> Maybe Library -> [Component]
    comp :: PkgName -> Name -> Maybe Library -> [Component]
comp PkgName
name Name
tag (Just Library {Name
sourceDirs :: Name
sourceDirs :: Library -> Name
sourceDirs}) =
      [ Component
          { path :: FilePath
path = FilePath
"./" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pkg -> ShowS
pkgFile Pkg
path (Name -> FilePath
forall a. ToString a => a -> FilePath
toString Name
sourceDirs),
            component :: Name
component = PkgName -> Name
forall a. Format a => a -> Name
format PkgName
name Name -> Name -> Name
forall a. (Semigroup a, IsString a) => a -> a -> a
<:> Name
tag
          }
      ]
    comp PkgName
_ Name
_ Maybe Library
_ = []

syncHie :: ConfigT ()
syncHie :: ConfigT ()
syncHie = do
  Options {Bool
FilePath
hie :: FilePath
hwm :: FilePath
stack :: FilePath
quiet :: Bool
quiet :: Options -> Bool
stack :: Options -> FilePath
hwm :: Options -> FilePath
hie :: Options -> FilePath
..} <- ConfigT Options
forall env (m :: * -> *).
(MonadReader env m, Has env Options) =>
m Options
askOptions
  [Component]
components <- [[Component]] -> [Component]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Component]] -> [Component])
-> ConfigT [[Component]] -> ConfigT [Component]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConfigT [Pkg]
askPackages ConfigT [Pkg]
-> ([Pkg] -> ConfigT [[Component]]) -> ConfigT [[Component]]
forall a b. ConfigT a -> (a -> ConfigT b) -> ConfigT b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pkg -> ConfigT [Component]) -> [Pkg] -> ConfigT [[Component]]
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 -> ConfigT [Component]
genComponents)
  FilePath -> (Maybe Value -> ConfigT Value) -> ConfigT ()
forall (m :: * -> *) t.
(MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) =>
FilePath -> (Maybe t -> m t) -> m ()
rewrite_ FilePath
hie (ConfigT Value -> Maybe Value -> ConfigT Value
forall a b. a -> b -> a
const (ConfigT Value -> Maybe Value -> ConfigT Value)
-> ConfigT Value -> Maybe Value -> ConfigT Value
forall a b. (a -> b) -> a -> b
$ Value -> ConfigT Value
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ConfigT Value) -> Value -> ConfigT Value
forall a b. (a -> b) -> a -> b
$ Components -> Value
packHie Components {stackYaml :: FilePath
stackYaml = FilePath
stack, [Component]
components :: [Component]
components :: [Component]
components})