Stack.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

module Axel.Haskell.Stack where

import Prelude hiding (putStrLn)

import Axel.Error (Error(ProjectError), fatal)
import Axel.Monad.Console (MonadConsole, putStrLn)
import Axel.Monad.FileSystem (MonadFileSystem)
import qualified Axel.Monad.FileSystem as FS
  ( MonadFileSystem(readFile, writeFile)
  , withCurrentDirectory
  )
import Axel.Monad.Process
  ( MonadProcess(runProcess, runProcessInheritingStreams)
  )

import Control.Lens.Operators ((%~))
import Control.Monad (void)
import Control.Monad.Except (MonadError, throwError)

import Data.Aeson.Lens (_Array, key)
import qualified Data.ByteString.Char8 as B (pack, unpack)
import Data.Function ((&))
import Data.List (foldl')
import qualified Data.Text as T (pack)
import Data.Vector (cons)
import Data.Version (showVersion)
import qualified Data.Yaml as Yaml (Value(String), decodeEither', encode)

import Paths_axel (version)

import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import System.FilePath (takeFileName)

import Text.Regex.PCRE ((=~), getAllTextSubmatches)

type ProjectPath = FilePath

type StackageId = String

type StackageResolver = String

type Target = String

type Version = String

stackageResolverWithAxel :: StackageResolver
stackageResolverWithAxel = "nightly-2018-08-20"

axelStackageVersion :: Version
axelStackageVersion = showVersion version

axelStackageId :: StackageId
axelStackageId = "axel-" <> showVersion version

axelStackageSpecifier :: StackageId
axelStackageSpecifier = "axel ==" <> axelStackageVersion

getStackProjectTargets ::
     (Monad m, MonadFileSystem m, MonadProcess m) => ProjectPath -> m [Target]
getStackProjectTargets projectPath =
  FS.withCurrentDirectory projectPath $ do
    (_, _, stderr) <- runProcess "stack" ["ide", "targets"] ""
    pure $ lines stderr

addStackDependency :: (MonadFileSystem m) => StackageId -> ProjectPath -> m ()
addStackDependency dependencyId projectPath =
  FS.withCurrentDirectory projectPath $ do
    let packageConfigPath = "package.yaml"
    packageConfigContents <- FS.readFile packageConfigPath
    case Yaml.decodeEither' $ B.pack packageConfigContents of
      Right contents ->
        let newContents :: Yaml.Value =
              contents & key "dependencies" . _Array %~
              cons (Yaml.String $ T.pack dependencyId)
            encodedContents = B.unpack $ Yaml.encode newContents
         in FS.writeFile packageConfigPath encodedContents
      Left _ -> fatal "addStackDependency" "0001"

buildStackProject ::
     (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m)
  => ProjectPath
  -> m ()
buildStackProject projectPath = do
  putStrLn ("Building " <> takeFileName projectPath <> "...")
  result <-
    FS.withCurrentDirectory projectPath $ runProcess "stack" ["build"] ""
  case result of
    (ExitSuccess, _, _) -> pure ()
    (ExitFailure _, stdout, stderr) ->
      throwError $
      ProjectError
        ("Project failed to build.\n\nStdout:\n" <> stdout <> "\n\nStderr:\n" <>
         stderr)

createStackProject :: (MonadFileSystem m, MonadProcess m) => String -> m ()
createStackProject projectName = do
  void $ runProcess "stack" ["new", projectName, "new-template"] ""
  setStackageResolver projectName stackageResolverWithAxel

runStackProject ::
     (MonadConsole m, MonadError Error m, MonadFileSystem m, MonadProcess m)
  => ProjectPath
  -> m ()
runStackProject projectPath = do
  targets <- getStackProjectTargets projectPath
  case findExeTargets targets of
    [target] -> do
      putStrLn ("Running " <> target <> "...")
      void $ runProcessInheritingStreams "stack" ["exec", target]
    _ ->
      throwError $ ProjectError "No executable target was unambiguously found!"
  where
    findExeTargets =
      foldl'
        (\acc target ->
           case getAllTextSubmatches $ target =~
                ("([^:]*):exe:([^:]*)" :: String) of
             [_fullMatch, _projectName, targetName] -> targetName : acc
             _ -> acc)
        []

setStackageResolver ::
     (MonadFileSystem m, MonadProcess m)
  => ProjectPath
  -> StackageResolver
  -> m ()
setStackageResolver projectPath resolver =
  void $ FS.withCurrentDirectory projectPath $
  runProcess "stack" ["config", "set", "resolver", resolver] ""