{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Importify.Stack
( QueryPackage (..)
, LocalPackages (..)
, RemotePackages (..)
, ghcIncludePath
, pkgName
, stackListDependencies
, stackListPackages
, stackProjectRoot
, upgradeWithVersions
) where
import Universum
import Data.List (partition)
import Data.Yaml (FromJSON (parseJSON), Parser, Value (Object), decodeEither',
prettyPrintParseException, withObject, (.:))
import Path (Abs, Dir, Path, PathException, dirname, fromAbsDir, mkRelDir, parent, parseAbsDir,
(</>))
import Path.IO (doesDirExist)
import System.FilePath (splitPath)
import Turtle (Line, Shell, inproc, lineToText, linesToText, need)
import Extended.System.Wlog (printWarning)
import qualified Control.Foldl as Fold (head, list)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Turtle (fold)
shStack :: [Text] -> Shell Line
shStack args = do
inNix <- inNixShell
inproc "stack" (if inNix then "--nix" : args else args) empty
inNixShell :: MonadIO m => m Bool
inNixShell = do
ns <- need "IN_NIX_SHELL"
pure $ ns == Just "1"
pathArgs, rootArgs, depsArgs :: [Text]
pathArgs = ["path", "--compiler-bin"]
rootArgs = ["path", "--project-root"]
depsArgs = ["list-dependencies", "--test", "--bench"]
ghcIncludePath :: MaybeT IO (Path Abs Dir)
ghcIncludePath = do
ghcBinLine <- MaybeT $ Turtle.fold (shStack pathArgs) Fold.head
ghcBinText <- parseAbsDir $ toString $ lineToText ghcBinLine
let ghcProgram = parent ghcBinText
let ghcName = dirname ghcProgram
let ghcIncludeDir = ghcProgram
</> $(mkRelDir "lib/")
</> ghcName
</> $(mkRelDir "include/")
guardM $ doesDirExist ghcIncludeDir
return ghcIncludeDir
stackProjectRoot :: MaybeT IO (Path Abs Dir)
stackProjectRoot = do
projectRootLine <- MaybeT $ Turtle.fold (shStack rootArgs) Fold.head
let projectRoot = lineToText projectRootLine
if ".stack/global-project" `T.isSuffixOf` projectRoot then
printWarning "importify was executed outside of project" *> empty
else case eitherParseRoot projectRoot of
Left exception -> printWarning (show exception) *> empty
Right projectRootPath -> return projectRootPath
where
eitherParseRoot :: Text -> Either SomeException (Path Abs Dir)
eitherParseRoot = parseAbsDir . toString
stackListDependencies :: MonadIO m => m (HashMap Text Text)
stackListDependencies = do
dependencies <- Turtle.fold (shStack depsArgs) Fold.list
let wordifyDeps = map (words . lineToText) dependencies
let pairifyDeps = pairifyList wordifyDeps
return $ HM.fromList pairifyDeps
where
pairifyList :: [[a]] -> [(a,a)]
pairifyList [] = []
pairifyList ([x,y]:xs) = (x,y) : pairifyList xs
pairifyList (_:xs) = pairifyList xs
upgradeWithVersions :: HashMap Text Text -> [Text] -> [Text]
upgradeWithVersions versions = go
where
go [] = []
go (lib:libs) = case HM.lookup lib versions of
Nothing -> lib : go libs
Just version -> lib <> "-" <> version : go libs
stackListPackages :: forall m . (MonadIO m, MonadCatch m)
=> m (LocalPackages, RemotePackages)
stackListPackages = do
pkgsYaml <- linesToText <$> Turtle.fold (shStack ["query"]) Fold.list
let parseRes = decodeEither' $ encodeUtf8 pkgsYaml
case parseRes of
Left exception -> do
printWarning $ toText $ prettyPrintParseException exception
return mempty
Right (StackQueryResult packages) -> do
localPackages <- mapM toPackage packages `catch` parseErrorHandler
let (locals, remotes) = partition (isLocalPackage . qpPath) localPackages
return (LocalPackages locals, RemotePackages remotes)
where
toPackage :: (Text, (FilePath, Text)) -> m QueryPackage
toPackage (qpName, (path, qpVersion)) = do
qpPath <- parseAbsDir path
return QueryPackage{..}
parseErrorHandler :: PathException -> m [QueryPackage]
parseErrorHandler exception =
[] <$ printWarning ("'stack query' exception: " <> show exception)
isLocalPackage :: Path Abs Dir -> Bool
isLocalPackage = notElem ".stack-work/" . splitPath . fromAbsDir
data QueryPackage = QueryPackage
{ qpName :: Text
, qpPath :: Path Abs Dir
, qpVersion :: Text
} deriving (Eq, Show)
pkgName :: QueryPackage -> Text
pkgName QueryPackage{..} = qpName <> "-" <> qpVersion
newtype LocalPackages = LocalPackages [QueryPackage]
deriving (Eq, Monoid)
newtype RemotePackages = RemotePackages [QueryPackage]
deriving (Eq, Monoid)
newtype StackQueryResult = StackQueryResult [(Text, (FilePath, Text))]
deriving Show
instance FromJSON StackQueryResult where
parseJSON = withObject "stack query" $ \obj -> do
Just (Object locals) <- pure $ HM.lookup "locals" obj
packages <- forM locals $ withObject "package" $ \pkgObj -> do
pkgPath :: FilePath <- pkgObj .: "path"
pkgVersion :: Text <- pkgObj .: "version"
pure (pkgPath, pkgVersion)
pure $ StackQueryResult $ HM.toList packages