ghcup-hs/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

module GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCOptions, CompileGHCMenu, create, handler, draw) where

import GHCup.Brick.Widgets.Menu (Menu)
import qualified GHCup.Brick.Widgets.Menu as Menu
import           GHCup.Brick.Common(Name(..))
import Brick
    ( BrickEvent(..),
      EventM,
      Widget(..))
import           Prelude                 hiding ( appendFile )
import           Optics.TH (makeLenses)
import qualified GHCup.Brick.Common as Common
import GHCup.Types (KeyCombination, BuildSystem (Hadrian))
import URI.ByteString (URI)
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
import GHCup.Utils (parseURI)
import Data.Bifunctor (Bifunctor(..))
import Data.Function ((&))
import Optics ((.~))
import Data.Char (isSpace)
import Data.Versions (Version, version)
import System.FilePath (isPathSeparator)
import Control.Applicative (Alternative((<|>)))
import Text.Read (readEither)

data CompileGHCOptions = CompileGHCOptions
  { _bootstrapGhc :: Either Version FilePath
  , _jobs         :: Maybe Int
  , _buildConfig  :: Maybe FilePath
  , _patches      :: Maybe (Either FilePath [URI])
  , _crossTarget  :: Maybe T.Text
  , _addConfArgs  :: [T.Text]
  , _setCompile   :: Bool
  , _ovewrwiteVer :: Maybe Version
  , _buildFlavour :: Maybe String
  , _buildSystem  :: Maybe BuildSystem
  , _isolateDir   :: Maybe FilePath
  } deriving (Eq, Show)

makeLenses ''CompileGHCOptions

type CompileGHCMenu = Menu CompileGHCOptions Name

create :: KeyCombination -> CompileGHCMenu
create k = Menu.createMenu CompileGHCBox initialState k buttons fields
  where
    initialState = 
      CompileGHCOptions 
        (Right "")
        Nothing
        Nothing
        Nothing
        Nothing
        []
        False
        Nothing
        Nothing
        Nothing
        Nothing
    -- Brick's internal editor representation is [mempty].
    emptyEditor i = T.null i || (i == "\n")
    whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a
    whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval

    bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath)
    bootstrapV i =
      case not $ emptyEditor i of
        True  -> 
          let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init
              readPath
                 = if isPathSeparator (T.head i) 
                    then pure $ Right (T.unpack i)
                    else Left "Not an absolute Path"
           in if T.any isPathSeparator i 
                then readPath
                else readVersion
        False -> Left "Invalid Empty value"

    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version)
    versionV = bimap (const "Not a valid version") Just . version . T.init  -- Brick adds \n at the end, hence T.init

    jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
    jobsV = 
      let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack
       in whenEmpty Nothing parseInt 

    patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI]))
    patchesV = whenEmpty Nothing readPatches
      where 
        readUri :: T.Text -> Either String URI
        readUri = first show . parseURI . UTF8.fromString . T.unpack 
        readPatches j = 
          let 
            x = (bimap T.unpack (fmap Left) $ filepathV j)
            y = second (Just . Right) $ traverse readUri (T.split isSpace j)
          in first T.pack $ x <|> y

    filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
    filepathV = whenEmpty Nothing (Right . Just . T.unpack)

    additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
    additionalValidator = Right . T.split isSpace

    systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem)
    systemV = whenEmpty Nothing readSys
      where 
        readSys i
          | T.toLower i == "hadrian" = Right $ Just Hadrian
          | T.toLower i == "make"    = Right $ Just Hadrian
          | otherwise = Left "Not a valid Build System"

    fields = 
      [ Menu.createEditableField (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapV bootstrapGhc
           & Menu.fieldLabelL .~ "bootstrap-ghc"
           & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)"
           & Menu.fieldStatusL .~ Menu.Invalid "Invalid Empty value"
      , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
          & Menu.fieldLabelL .~ "jobs"
          & Menu.fieldHelpMsgL .~ "How many jobs to use for make"
      , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig
          & Menu.fieldLabelL .~ "build config"
          & Menu.fieldHelpMsgL .~ "Absolute path to build config file"
      , Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches
          & Menu.fieldLabelL .~ "patches"
          & Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory"
      , Menu.createEditableField (Common.MenuElement Common.CrossTargetEditBox) (Right . Just) crossTarget
          & Menu.fieldLabelL .~ "cross target"
          & Menu.fieldHelpMsgL .~ "Build cross-compiler for this platform"
      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs
          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
          & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)"
      , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
          & Menu.fieldLabelL .~ "set"
          & Menu.fieldHelpMsgL .~ "Set as active version after install"
      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV ovewrwiteVer
          & Menu.fieldLabelL .~ "overwrite-version"
          & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
      , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour
          & Menu.fieldLabelL .~ "flavour"
          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
      , Menu.createEditableField (Common.MenuElement Common.BuildSystemEditBox) systemV buildSystem
          & Menu.fieldLabelL .~ "build system"
          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
      , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir
          & Menu.fieldLabelL .~ "isolated"
          & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"
      ]

    buttons = [
       Menu.createButtonField (Common.MenuElement Common.OkButton)
           & Menu.fieldLabelL .~ "Compile"
           & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below"
      ]

handler :: BrickEvent Name e -> EventM Name CompileGHCMenu ()
handler = Menu.handlerMenu


draw :: CompileGHCMenu -> Widget Name
draw = Common.frontwardLayer "Compile GHC" . Menu.drawMenu