serokell/importify

{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

-- | Utilities which allows to use @stack@ tools for different
-- dependencies stuff.

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

-- | Checks if running in nix shell
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"]

-- | This function finds path to directory where @include@ for ghc lies.
-- Filepath looks like this:
-- @
--   ~/.stack/programs/x86_64-linux/ghc-8.0.2/lib/ghc-8.0.2/include
-- @
-- This function needed to tell dependencies about files like @"MachDeps.h"@.
--
-- TODO: use GHC path from project?
ghcIncludePath :: MaybeT IO (Path Abs Dir)
ghcIncludePath = do
    ghcBinLine <- MaybeT $ Turtle.fold (shStack pathArgs) Fold.head

    -- ghcBinText ≡ /home/user/.stack/programs/x86_64-linux/ghc-8.0.2/bin
    ghcBinText    <- parseAbsDir $ toString $ lineToText ghcBinLine
    let ghcProgram = parent ghcBinText   -- w/o bin
    let ghcName    = dirname ghcProgram  -- ≡ ghc-8.0.2

    -- ghcInclude ≡ /home/user/.stack/programs/x86_64-linux/ghc-8.0.2/lib/ghc-8.0.2/include
    let ghcIncludeDir = ghcProgram
                    </> $(mkRelDir "lib/")
                    </> ghcName
                    </> $(mkRelDir "include/")

    guardM $ doesDirExist ghcIncludeDir
    return ghcIncludeDir

-- | Acquires project using @stack path --project-root@ command.
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

-- | Extract all dependencies with versions using
-- @stack list-dependencies@ shell command.
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

-- | Takes mapping from package names to their versions and list of
-- packages adding version to each package which is inside dictionary.
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

-- | Queries list of all local packages for project. If some errors
-- occur then warning is printed into console and empty list returned.
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

-- | This data type represents package returned by @stack query@ command.
data QueryPackage = QueryPackage
    { qpName    :: Text          -- ^ @importify@
    , qpPath    :: Path Abs Dir  -- ^ @\/home\/user\/importify\/@
    , qpVersion :: Text          -- ^ 1.0
    } deriving (Eq, Show)

-- | Show full name of 'QueryPackage' with version.
pkgName :: QueryPackage -> Text
pkgName QueryPackage{..} = qpName <> "-" <> qpVersion

-- | Local subpackages from exactly this project.
newtype LocalPackages = LocalPackages [QueryPackage]
    deriving (Eq, Monoid)

-- | Remote packages, from GitHub or other locations.
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