module HaskellWorks.Polysemy.Cabal
( findDefaultPlanJsonFile
, getPlanJsonFile
, binDist
) where
import HaskellWorks.Polysemy.Cabal.Types
import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS
import HaskellWorks.Polysemy.Error.Types
import HaskellWorks.Polysemy.Prelude
import HaskellWorks.Polysemy.System.Directory
import HaskellWorks.Polysemy.System.Environment
import System.FilePath (takeDirectory)
import Data.Aeson
import qualified Data.List as L
import qualified HaskellWorks.Polysemy.Data.Text as T
import HaskellWorks.Polysemy.FilePath
import Polysemy
import Polysemy.Error
import Polysemy.Log
findDefaultPlanJsonFile :: ()
=> Member (Embed IO) r
=> Member (Error IOException) r
=> Member Log r
=> Sem r FilePath
findDefaultPlanJsonFile :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
Sem r FilePath
findDefaultPlanJsonFile = Sem r FilePath
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
Sem r FilePath
getCurrentDirectory Sem r FilePath -> (FilePath -> Sem r FilePath) -> Sem r FilePath
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Sem r FilePath
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
FilePath -> Sem r FilePath
go
where go :: ()
=> Member (Embed IO) r
=> Member (Error IOException) r
=> Member Log r
=> FilePath
-> Sem r FilePath
go :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
FilePath -> Sem r FilePath
go FilePath
d = do
let file :: FilePath
file = FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
"dist-newstyle/cache/plan.json"
Bool
exists <- FilePath -> Sem r Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
FilePath -> Sem r Bool
doesFileExist FilePath
file
if Bool
exists
then FilePath -> Sem r FilePath
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
else do
let parent :: FilePath
parent = FilePath -> FilePath
takeDirectory FilePath
d
if FilePath
parent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
d
then FilePath -> Sem r FilePath
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"dist-newstyle/cache/plan.json"
else FilePath -> Sem r FilePath
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
FilePath -> Sem r FilePath
go FilePath
parent
getPlanJsonFile :: ()
=> Member (Embed IO) r
=> Member (Error IOException) r
=> Member Log r
=> Sem r String
getPlanJsonFile :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
Sem r FilePath
getPlanJsonFile = do
Maybe FilePath
maybeBuildDir <- FilePath -> Sem r (Maybe FilePath)
forall (r :: EffectRow).
(HasCallStack, Member (Embed IO) r) =>
FilePath -> Sem r (Maybe FilePath)
lookupEnv FilePath
"CABAL_BUILDDIR"
case Maybe FilePath
maybeBuildDir of
Just FilePath
buildDir -> FilePath -> Sem r FilePath
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Sem r FilePath) -> FilePath -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
".." FilePath -> FilePath -> FilePath
</> FilePath
buildDir FilePath -> FilePath -> FilePath
</> FilePath
"cache/plan.json"
Maybe FilePath
Nothing -> Sem r FilePath
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
Sem r FilePath
findDefaultPlanJsonFile
binDist:: ()
=> Member (Embed IO) r
=> Member (Error GenericError) r
=> Member (Error IOException) r
=> Member Log r
=> String
-> Sem r FilePath
binDist :: forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error GenericError) r,
Member (Error IOException) r, Member Log r) =>
FilePath -> Sem r FilePath
binDist FilePath
pkg = do
FilePath
planJsonFile <- Sem r FilePath
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r,
Member Log r) =>
Sem r FilePath
getPlanJsonFile
ByteString
contents <- FilePath -> Sem r ByteString
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
FilePath -> Sem r ByteString
LBS.readFile FilePath
planJsonFile
case ByteString -> Either FilePath Plan
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
contents of
Right Plan
plan -> case (Component -> Bool) -> [Component] -> [Component]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Component -> Bool
matching (Plan
plan Plan -> (Plan -> [Component]) -> [Component]
forall a b. a -> (a -> b) -> b
& Plan -> [Component]
installPlan) of
(Component
component:[Component]
_) -> case Component
component Component -> (Component -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Component -> Maybe Text
binFile of
Just Text
bin -> FilePath -> Sem r FilePath
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Sem r FilePath) -> FilePath -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
addExeSuffix (Text -> FilePath
T.unpack Text
bin)
Maybe Text
Nothing -> GenericError -> Sem r FilePath
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (GenericError -> Sem r FilePath) -> GenericError -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ Text -> GenericError
GenericError (Text -> GenericError) -> Text -> GenericError
forall a b. (a -> b) -> a -> b
$ Text
"Missing bin-file in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Component -> Text
forall a. Show a => a -> Text
tshow Component
component
[] -> GenericError -> Sem r FilePath
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (GenericError -> Sem r FilePath) -> GenericError -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ Text -> GenericError
GenericError (Text -> GenericError) -> Text -> GenericError
forall a b. (a -> b) -> a -> b
$ Text
"Cannot find exe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Show a => a -> Text
tshow FilePath
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in plan"
Left FilePath
msg -> GenericError -> Sem r FilePath
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (GenericError -> Sem r FilePath) -> GenericError -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ Text -> GenericError
GenericError (Text -> GenericError) -> Text -> GenericError
forall a b. (a -> b) -> a -> b
$ Text
"Cannot decode plan: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
msg
where matching :: Component -> Bool
matching :: Component -> Bool
matching Component
component = case Component -> Maybe Text
componentName Component
component of
Just Text
name -> Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"exe:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pkg
Maybe Text
Nothing -> Bool
False